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   (eval-when-compile (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 copy-list (&whole form list)
  79     (if (and (fboundp 'copy-list)
  80              (subrp (symbol-function 'copy-list)))
  81         form
  82       `(let ((list ,list))
  83          (if (consp list)
  84              (let ((res nil))
  85                (while (consp list) (push (pop list) res))
  86                (prog1 (nreverse res) (setcdr res list)))
  87            (car list)))))
  88
  89   (define-compiler-macro last (&whole form x &optional n)
  90     (if (and (fboundp 'last)
  91              (subrp (symbol-function 'last)))
  92         form
  93       (if n
  94           `(let* ((x ,x)
  95                   (n ,n)
  96                   (m 0)
  97                   (p x))
  98              (while (consp p)
  99                (incf m)
 100                (pop p))
 101              (if (<= n 0)
 102                  p
 103                (if (< n m)
 104                    (nthcdr (- m n) x)
 105                  x)))
 106         `(let ((x ,x))
 107            (while (consp (cdr x))
 108              (pop x))
 109            x))))
 110
 111   (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
 112     (if (and (fboundp 'merge)
 113              (subrp (symbol-function 'merge)))
 114         form
 115       `(let ((type ,type)
 116              (seq1 ,seq1)
 117              (seq2 ,seq2)
 118              (pred ,pred))
 119          (or (listp seq1) (setq seq1 (append seq1 nil)))
 120          (or (listp seq2) (setq seq2 (append seq2 nil)))
 121          (let ((res nil))
 122            (while (and seq1 seq2)
 123              (if (funcall pred (car seq2) (car seq1))
 124                  (push (pop seq2) res)
 125                (push (pop seq1) res)))
 126            (coerce (nconc (nreverse res) seq1 seq2) type)))))
 127
 128   (define-compiler-macro string (&whole form &rest args)
 129     (if (and (fboundp 'string)
 130              (subrp (symbol-function 'string)))
 131         form
 132       (list 'concat (cons 'list args))))
 133
 134   (defun-maybe string (&rest args)
 135     "Concatenate all the argument characters and make the result a string."
 136     (concat args))
 137
 138   (define-compiler-macro string-to-list (&whole form string)
 139     (cond ((fboundp 'string-to-list)
 140            form)
 141           ((fboundp 'string-to-char-list)
 142            (list 'string-to-char-list string))
 143           (t
 144            `(let* ((str ,string)
 145                    (len (length str))
 146                    (idx 0)
 147                    c l)
 148               (while (< idx len)
 149                 (setq c (sref str idx))
 150                 (setq idx (+ idx (char-bytes c)))
 151                 (setq l (cons c l)))
 152               (nreverse l)))))
 153
 154   ;; 92.7.2 by K.Handa (imported from Mule 2.3)
 155   (defun-maybe string-to-list (str)
 156     (let ((len (length str))
 157           (idx 0)
 158           c l)
 159       (while (< idx len)
 160         (setq c (sref str idx))
 161         (setq idx (+ idx (char-bytes c)))
 162         (setq l (cons c l)))
 163       (nreverse l)))
 164
 165   (define-compiler-macro subseq (&whole form seq start &optional end)
 166     (if (and (fboundp 'subseq)
 167              (subrp (symbol-function 'subseq)))
 168         form
 169       (if end
 170           `(let ((seq ,seq)
 171                  (start ,start)
 172                  (end ,end))
 173              (if (stringp seq)
 174                  (substring seq start end)
 175                (let (len)
 176                  (if (< end 0)
 177                      (setq end (+ end (setq len (length seq)))))
 178                  (if (< start 0)
 179                      (setq start (+ start (or len (setq len (length seq))))))
 180                  (cond ((listp seq)
 181                         (if (> start 0)
 182                             (setq seq (nthcdr start seq)))
 183                         (let ((res nil))
 184                           (while (>= (setq end (1- end)) start)
 185                             (push (pop seq) res))
 186                           (nreverse res)))
 187                        (t
 188                         (let ((res (make-vector (max (- end start) 0) nil))
 189                               (i 0))
 190                           (while (< start end)
 191                             (aset res i (aref seq start))
 192                             (setq i (1+ i)
 193                                   start (1+ start)))
 194                           res))))))
 195         `(let ((seq ,seq)
 196                (start ,start))
 197            (if (stringp seq)
 198                (substring seq start)
 199              (let (len)
 200                (if (< start 0)
 201                    (setq start (+ start (or len (setq len (length seq))))))
 202                (cond ((listp seq)
 203                       (if (> start 0)
 204                           (setq seq (nthcdr start seq)))
 205                       (copy-sequence seq))
 206                      (t
 207                       (let* ((end (or len (length seq)))
 208                              (res (make-vector (max (- end start) 0) nil))
 209                              (i 0))
 210                         (while (< start end)
 211                           (aset res i (aref seq start))
 212                           (setq i (1+ i)
 213                                 start (1+ start)))
 214                         res)))))))))
 215   )
 216
 217 ;; A tool for the developers.
 218
 219 (defvar cl-run-time-functions
 220   '(Values
 221     Values-list acons assoc-if assoc-if-not build-klist butlast ceiling*
 222     coerce common-lisp-indent-function compiler-macroexpand concatenate
 223     copy-list count count-if count-if-not delete* delete-duplicates delete-if
 224     delete-if-not duplicate-symbols-p elt-satisfies-test-p equalp evenp every
 225     extract-from-klist fill find find-if find-if-not floatp-safe floor* gcd
 226     gensym gentemp get-setf-method getf hash-table-count hash-table-p
 227     intersection isqrt keyword-argument-supplied-p keyword-of keywordp last
 228     lcm ldiff lisp-indent-259 lisp-indent-do lisp-indent-function-lambda-hack
 229     lisp-indent-report-bad-format lisp-indent-tagbody list-length
 230     make-hash-table make-random-state map mapc mapcan mapcar* mapcon mapl
 231     maplist member-if member-if-not merge mismatch mod* nbutlast nintersection
 232     notany notevery nreconc nset-difference nset-exclusive-or nsublis nsubst
 233     nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not
 234     nunion oddp pair-with-newsyms pairlis position position-if position-if-not
 235     proclaim random* random-state-p rassoc* rassoc-if rassoc-if-not
 236     reassemble-argslists reduce rem* remove remove* remove-duplicates
 237     remove-if remove-if-not remq replace revappend round* safe-idiv search
 238     set-difference set-exclusive-or setelt setnth setnthcdr signum some sort*
 239     stable-sort sublis subseq subsetp subst subst-if subst-if-not substitute
 240     substitute-if substitute-if-not tailp tree-equal truncate* union
 241     unzip-lists zip-lists)
 242   "A list of CL run-time functions.  Some functions were built-in, nowadays.")
 243
 244 ;;;###autoload
 245 (defun find-cl-run-time-functions (file-or-directory arg)
 246   "Find CL run-time functions in the FILE-OR-DIRECTORY.  You can alter
 247 the behavior of this command with the prefix ARG as described below.
 248
 249 By default, it searches for all the CL run-time functions listed in
 250  the variable `cl-run-time-functions'.
 251 With 1 or 3 \\[universal-argument]'s, the built-in functions in this Emacs\
 252  will not be
 253  reported.
 254 With 2 or 3 \\[universal-argument]'s, just the symbols will also be reported.
 255
 256 You can use the `digit-argument' 1, 2 or 3 instead of\
 257  \\[universal-argument]'s."
 258   (interactive (list (read-file-name "Find CL run-time functions in: "
 259                                      nil default-directory t)
 260                      current-prefix-arg))
 261   (unless (interactive-p)
 262     (error "You should invoke `M-x find-cl-run-time-functions' interactively"))
 263   (let ((report-symbols (member arg '((16) (64) 2 3)))
 264         files clfns working file lines form forms fns fn newform buffer
 265         window scroll
 266         buffer-file-format format-alist
 267         insert-file-contents-post-hook insert-file-contents-pre-hook)
 268     (cond ((file-directory-p file-or-directory)
 269            (setq files (directory-files file-or-directory t "\\.el$"))
 270            (dolist (file files)
 271              (unless (file-exists-p file)
 272                (setq files (delete file files))))
 273            (unless files
 274              (message "No files found in: %s" file-or-directory))
 275            files)
 276           ((file-exists-p file-or-directory)
 277            (setq files (list file-or-directory)))
 278           (t
 279            (message "No such file or directory: %s" file-or-directory)))
 280     (when files
 281       (if (member arg '((4) (64) 1 3))
 282           (dolist (fn cl-run-time-functions)
 283             (unless (and (fboundp fn)
 284                          (subrp (symbol-function fn)))
 285               (push fn clfns)))
 286         (setq clfns cl-run-time-functions))
 287       (set-buffer (setq working
 288                         (get-buffer-create
 289                          " *Searching for CL run-time functions*")))
 290       (let (emacs-lisp-mode-hook)
 291         (emacs-lisp-mode))
 292       (while files
 293         (setq file (pop files)
 294               lines (list nil nil))
 295         (message "Searching for CL run-time functions in: %s..."
 296                  (file-name-nondirectory file))
 297         (insert-file-contents file nil nil nil t)
 298         ;; XEmacs moves point to the beginning of the buffer after
 299         ;; inserting a file, FSFmacs doesn't so if the fifth argument
 300         ;; of `insert-file-contents' is specified.
 301         (goto-char (point-min))
 302         ;;
 303         (while (progn
 304                  (while (and (looking-at "[\t\v\f\r ]*\\(;.*\\)?$")
 305                              (zerop (forward-line 1))))
 306                  (not (eobp)))
 307           (setcar lines (if (bolp)
 308                             (1+ (count-lines (point-min) (point)))
 309                           (count-lines (point-min) (point))))
 310           (when (consp;; Ignore stand-alone symbols, strings, etc.
 311                  (setq form (condition-case nil
 312                                 (read working)
 313                               (error nil))))
 314             (setcdr lines (list (count-lines (point-min) (point))))
 315             (setq forms (list form)
 316                   fns nil)
 317             (while forms
 318               (setq form (pop forms))
 319               (when (consp form)
 320                 (setq fn (pop form))
 321                 (cond ((memq fn '(apply mapatoms mapcar mapconcat
 322                                         mapextent symbol-function))
 323                        (if (consp (car form))
 324                            (when (memq (caar form) '(\` backquote quote))
 325                              (setcar form (cdar form)))
 326                          (setq form (cdr form))))
 327                       ((memq fn '(\` backquote quote))
 328                        (if report-symbols
 329                            (progn
 330                              (setq form (car form)
 331                                    newform nil)
 332                              (while form
 333                                (push (list (or (car-safe form) form))
 334                                      newform)
 335                                (setq form (cdr-safe form)))
 336                              (setq form (nreverse newform)))
 337                          (setq form nil)))
 338                       ((memq fn '(defadvice
 339                                    defmacro defsubst defun
 340                                    defmacro-maybe defmacro-maybe-cond
 341                                    defsubst-maybe defun-maybe
 342                                    defun-maybe-cond))
 343                        (setq form (cddr form)))
 344                       ((memq fn '(defalias lambda fset))
 345                        (setq form (cdr form)))
 346                       ((eq fn 'define-compiler-macro)
 347                        (setq form nil))
 348                       ((eq fn 'dolist)
 349                        (setcar form (cadar form)))
 350                       ((memq fn '(let let*))
 351                        (setq form
 352                              (append
 353                               (delq nil
 354                                     (mapcar
 355                                      (lambda (element)
 356                                        (when (and (consp element)
 357                                                   (consp (cadr element)))
 358                                          (cadr element)))
 359                                      (car form)))
 360                               (cdr form))))
 361                       ((eq fn 'sort)
 362                        (when (and (consp (cadr form))
 363                                   (memq (caadr form) '(\` backquote quote)))
 364                          (setcdr form (list (cdadr form)))))
 365                       ((and (memq fn clfns)
 366                             (listp form))
 367                        (push fn fns)))
 368                 (setq forms (append form forms))))
 369             (when fns
 370               (if buffer
 371                   (set-buffer buffer)
 372                 (display-buffer
 373                  (setq buffer (get-buffer-create
 374                                (concat "*CL run-time functions in: "
 375                                        file-or-directory "*"))))
 376                 (set-buffer buffer)
 377                 (erase-buffer)
 378                 (setq window (get-buffer-window buffer t)
 379                       scroll (- 2 (window-height window))
 380                       fill-column (max 16 (- (window-width window) 2))
 381                       fill-prefix "               "))
 382               (when file
 383                 (insert file "\n")
 384                 (setq file nil))
 385               (narrow-to-region
 386                (point)
 387                (progn
 388                  (insert fill-prefix
 389                          (mapconcat (lambda (fn) (format "%s" fn))
 390                                     (nreverse fns) " "))
 391                  (point)))
 392               (fill-region (point-min) (point-max))
 393               (goto-char (point-min))
 394               (widen)
 395               (delete-char 14)
 396               (insert (format "%5d - %5d:" (car lines) (cadr lines)))
 397               (goto-char (point-max))
 398               (forward-line scroll)
 399               (set-window-start window (point))
 400               (goto-char (point-max))
 401               (sit-for 0)
 402               (set-buffer working)))))
 403       (kill-buffer working)
 404       (if buffer
 405           (message "Done")
 406         (message "No CL run-time functions found in: %s"
 407                  file-or-directory)))))
 408
 409 (provide 'gnus-clfns)
 410
 411 ;;; gnus-clfns.el ends here