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

   1 ;;; gnus-clfns.el --- compiler macros for emulating cl functions
   2
   3 ;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
   4
   5 ;; Author: Kastsumi Yamaoka <yamaoka@jpl.org>
   6 ;; Keywords: cl, compile
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This module is for mainly avoiding cl runtime functions in FSF
  28 ;; Emacsen.  Function should also be defined as an ordinary function
  29 ;; if it will not be provided in cl.
  30
  31 ;;; Code:
  32
  33 (if (featurep 'xemacs)
  34     nil
  35   (eval-when-compile (require 'cl))
  36   (require 'pym)
  37
  38   (define-compiler-macro assq-delete-all (&whole form key alist)
  39     (if (>= emacs-major-version 21)
  40         form
  41       `(let* ((key ,key)
  42               (alist ,alist)
  43               (tail alist))
  44          (while tail
  45            (if (and (consp (car tail)) (eq (car (car tail)) key))
  46                (setq alist (delq (car tail) alist)))
  47            (setq tail (cdr tail)))
  48          alist)))
  49
  50   (define-compiler-macro butlast (&whole form x &optional n)
  51     (if (>= emacs-major-version 21)
  52         form
  53       (if n
  54           `(let ((x ,x)
  55                  (n ,n))
  56              (if (and n (<= n 0))
  57                  x
  58                (let ((m (length x)))
  59                  (or n (setq n 1))
  60                  (and (< n m)
  61                       (progn
  62                         (if (> n 0)
  63                             (progn
  64                               (setq x (copy-sequence x))
  65                               (setcdr (nthcdr (- (1- m) n) x) nil)))
  66                         x)))))
  67         `(let* ((x ,x)
  68                 (m (length x)))
  69            (and (< 1 m)
  70                 (progn
  71                   (setq x (copy-sequence x))
  72                   (setcdr (nthcdr (- m 2) x) nil)
  73                   x))))))
  74
  75 ;;  (define-compiler-macro coerce (&whole form x type)
  76 ;;    (if (and (fboundp 'coerce)
  77 ;;           (subrp (symbol-function 'coerce)))
  78 ;;      form
  79 ;;      `(let ((x ,x)
  80 ;;           (type ,type))
  81 ;;       (cond ((eq type 'list) (if (listp x) x (append x nil)))
  82 ;;             ((eq type 'vector) (if (vectorp x) x (vconcat x)))
  83 ;;             ((eq type 'string) (if (stringp x) x (concat x)))
  84 ;;             ((eq type 'array) (if (arrayp x) x (vconcat x)))
  85 ;;             ((and (eq type 'character) (stringp x) (= (length x) 1))
  86 ;;              (aref x 0))
  87 ;;             ((and (eq type 'character) (symbolp x)
  88 ;;                   (= (length (symbol-name x)) 1))
  89 ;;              (aref (symbol-name x) 0))
  90 ;;             ((eq type 'float) (float x))
  91 ;;             ((typep x type) x)
  92 ;;             (t (error "Can't coerce %s to type %s" x type))))))
  93
  94 ;;  (define-compiler-macro copy-list (&whole form list)
  95 ;;    (if (and (fboundp 'copy-list)
  96 ;;           (subrp (symbol-function 'copy-list)))
  97 ;;      form
  98 ;;      `(let ((list ,list))
  99 ;;       (if (consp list)
 100 ;;           (let ((res nil))
 101 ;;             (while (consp list) (push (pop list) res))
 102 ;;             (prog1 (nreverse res) (setcdr res list)))
 103 ;;         (car list)))))
 104
 105   (define-compiler-macro last (&whole form x &optional n)
 106     (if (>= emacs-major-version 20)
 107         form
 108       (if n
 109           `(let* ((x ,x)
 110                   (n ,n)
 111                   (m 0)
 112                   (p x))
 113              (while (consp p)
 114                (incf m)
 115                (pop p))
 116              (if (<= n 0)
 117                  p
 118                (if (< n m)
 119                    (nthcdr (- m n) x)
 120                  x)))
 121         `(let ((x ,x))
 122            (while (consp (cdr x))
 123              (pop x))
 124            x))))
 125
 126   (define-compiler-macro mapc (&whole form fn seq &rest rest)
 127     (if (>= emacs-major-version 21)
 128         form
 129       (if rest
 130           `(let* ((fn ,fn)
 131                   (seq ,seq)
 132                   (args (list seq ,@rest))
 133                   (m (apply (function min) (mapcar (function length) args)))
 134                   (n 0))
 135              (while (< n m)
 136                (apply fn (mapcar (function (lambda (arg) (nth n arg))) args))
 137                (setq n (1+ n)))
 138              seq)
 139         `(let ((seq ,seq))
 140            (mapcar ,fn seq)
 141            seq))))
 142
 143 ;;  (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
 144 ;;    (if (and (fboundp 'merge)
 145 ;;           (subrp (symbol-function 'merge)))
 146 ;;      form
 147 ;;      `(let ((type ,type)
 148 ;;           (seq1 ,seq1)
 149 ;;           (seq2 ,seq2)
 150 ;;           (pred ,pred))
 151 ;;       (or (listp seq1) (setq seq1 (append seq1 nil)))
 152 ;;       (or (listp seq2) (setq seq2 (append seq2 nil)))
 153 ;;       (let ((res nil))
 154 ;;         (while (and seq1 seq2)
 155 ;;           (if (funcall pred (car seq2) (car seq1))
 156 ;;               (push (pop seq2) res)
 157 ;;             (push (pop seq1) res)))
 158 ;;         (coerce (nconc (nreverse res) seq1 seq2) type)))))
 159
 160 ;;  (define-compiler-macro string (&whole form &rest args)
 161 ;;    (if (>= emacs-major-version 20)
 162 ;;      form
 163 ;;      (list 'concat (cons 'list args))))
 164
 165 ;;  (defun-maybe string (&rest args)
 166 ;;    "Concatenate all the argument characters and make the result a string."
 167 ;;    (concat args))
 168
 169   (define-compiler-macro string-to-list (&whole form string)
 170     (cond ((fboundp 'string-to-list)
 171            form)
 172           ((fboundp 'string-to-char-list)
 173            (list 'string-to-char-list string))
 174           (t
 175            `(let* ((str ,string)
 176                    (len (length str))
 177                    (idx 0)
 178                    c l)
 179               (while (< idx len)
 180                 (setq c (sref str idx))
 181                 (setq idx (+ idx (char-bytes c)))
 182                 (setq l (cons c l)))
 183               (nreverse l)))))
 184
 185   ;; 92.7.2 by K.Handa (imported from Mule 2.3)
 186   (defun-maybe string-to-list (str)
 187     (let ((len (length str))
 188           (idx 0)
 189           c l)
 190       (while (< idx len)
 191         (setq c (sref str idx))
 192         (setq idx (+ idx (char-bytes c)))
 193         (setq l (cons c l)))
 194       (nreverse l)))
 195
 196 ;;  (define-compiler-macro subseq (&whole form seq start &optional end)
 197 ;;    (if (and (fboundp 'subseq)
 198 ;;           (subrp (symbol-function 'subseq)))
 199 ;;      form
 200 ;;      (if end
 201 ;;        `(let ((seq ,seq)
 202 ;;               (start ,start)
 203 ;;               (end ,end))
 204 ;;           (if (stringp seq)
 205 ;;               (substring seq start end)
 206 ;;             (let (len)
 207 ;;               (if (< end 0)
 208 ;;                   (setq end (+ end (setq len (length seq)))))
 209 ;;               (if (< start 0)
 210 ;;                   (setq start (+ start (or len (setq len (length seq))))))
 211 ;;               (cond ((listp seq)
 212 ;;                      (if (> start 0)
 213 ;;                          (setq seq (nthcdr start seq)))
 214 ;;                      (let ((res nil))
 215 ;;                        (while (>= (setq end (1- end)) start)
 216 ;;                          (push (pop seq) res))
 217 ;;                        (nreverse res)))
 218 ;;                     (t
 219 ;;                      (let ((res (make-vector (max (- end start) 0) nil))
 220 ;;                            (i 0))
 221 ;;                        (while (< start end)
 222 ;;                          (aset res i (aref seq start))
 223 ;;                          (setq i (1+ i)
 224 ;;                                start (1+ start)))
 225 ;;                        res))))))
 226 ;;      `(let ((seq ,seq)
 227 ;;             (start ,start))
 228 ;;         (if (stringp seq)
 229 ;;             (substring seq start)
 230 ;;           (let (len)
 231 ;;             (if (< start 0)
 232 ;;                 (setq start (+ start (or len (setq len (length seq))))))
 233 ;;             (cond ((listp seq)
 234 ;;                    (if (> start 0)
 235 ;;                        (setq seq (nthcdr start seq)))
 236 ;;                    (copy-sequence seq))
 237 ;;                   (t
 238 ;;                    (let* ((end (or len (length seq)))
 239 ;;                           (res (make-vector (max (- end start) 0) nil))
 240 ;;                           (i 0))
 241 ;;                      (while (< start end)
 242 ;;                        (aset res i (aref seq start))
 243 ;;                        (setq i (1+ i)
 244 ;;                              start (1+ start)))
 245 ;;                      res)))))))))
 246   )
 247
 248 ;; A tool for the developers.
 249
 250 (defvar cl-run-time-functions
 251   '(Values
 252     Values-list acons assoc-if assoc-if-not build-klist butlast ceiling*
 253     coerce common-lisp-indent-function compiler-macroexpand concatenate
 254     copy-list count count-if count-if-not delete* delete-duplicates delete-if
 255     delete-if-not duplicate-symbols-p elt-satisfies-test-p equalp evenp every
 256     extract-from-klist fill find find-if find-if-not floatp-safe floor* gcd
 257     gensym gentemp get-setf-method getf hash-table-count hash-table-p
 258     intersection isqrt keyword-argument-supplied-p keyword-of keywordp last
 259     lcm ldiff lisp-indent-259 lisp-indent-do lisp-indent-function-lambda-hack
 260     lisp-indent-report-bad-format lisp-indent-tagbody list-length
 261     make-hash-table make-random-state map mapc mapcan mapcar* mapcon mapl
 262     maplist member-if member-if-not merge mismatch mod* nbutlast nintersection
 263     notany notevery nreconc nset-difference nset-exclusive-or nsublis nsubst
 264     nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not
 265     nunion oddp pair-with-newsyms pairlis position position-if position-if-not
 266     proclaim random* random-state-p rassoc* rassoc-if rassoc-if-not
 267     reassemble-argslists reduce rem* remove remove* remove-duplicates
 268     remove-if remove-if-not remq replace revappend round* safe-idiv search
 269     set-difference set-exclusive-or setelt setnth setnthcdr signum some sort*
 270     stable-sort sublis subseq subsetp subst subst-if subst-if-not substitute
 271     substitute-if substitute-if-not tailp tree-equal truncate* union
 272     unzip-lists zip-lists)
 273   "A list of CL run-time functions.  Some functions were built-in, nowadays.")
 274
 275 ;;;###autoload
 276 (defun find-cl-run-time-functions (file-or-directory arg)
 277   "Find CL run-time functions in the FILE-OR-DIRECTORY.  You can alter
 278 the behavior of this command with the prefix ARG as described below.
 279
 280 By default, it searches for all the CL run-time functions listed in
 281  the variable `cl-run-time-functions'.
 282 With 1 or 3 \\[universal-argument]'s, the built-in functions in this Emacs\
 283  will not be
 284  reported.
 285 With 2 or 3 \\[universal-argument]'s, just the symbols will also be reported.
 286
 287 You can use the `digit-argument' 1, 2 or 3 instead of\
 288  \\[universal-argument]'s."
 289   (interactive (list (read-file-name "Find CL run-time functions in: "
 290                                      nil default-directory t)
 291                      current-prefix-arg))
 292   (unless (interactive-p)
 293     (error "You should invoke `M-x find-cl-run-time-functions' interactively"))
 294   (let ((report-symbols (member arg '((16) (64) 2 3)))
 295         files clfns working file lines form forms fns fn newform buffer
 296         window scroll
 297         buffer-file-format format-alist
 298         insert-file-contents-post-hook insert-file-contents-pre-hook)
 299     (cond ((file-directory-p file-or-directory)
 300            (setq files (directory-files file-or-directory t "\\.el$"))
 301            (dolist (file files)
 302              (unless (file-exists-p file)
 303                (setq files (delete file files))))
 304            (unless files
 305              (message "No files found in: %s" file-or-directory))
 306            files)
 307           ((file-exists-p file-or-directory)
 308            (setq files (list file-or-directory)))
 309           (t
 310            (message "No such file or directory: %s" file-or-directory)))
 311     (when files
 312       (if (member arg '((4) (64) 1 3))
 313           (dolist (fn cl-run-time-functions)
 314             (unless (and (fboundp fn)
 315                          (subrp (symbol-function fn)))
 316               (push fn clfns)))
 317         (setq clfns cl-run-time-functions))
 318       (set-buffer (setq working
 319                         (get-buffer-create
 320                          " *Searching for CL run-time functions*")))
 321       (let (emacs-lisp-mode-hook)
 322         (emacs-lisp-mode))
 323       (while files
 324         (setq file (pop files)
 325               lines (list nil nil))
 326         (message "Searching for CL run-time functions in: %s..."
 327                  (file-name-nondirectory file))
 328         (insert-file-contents file nil nil nil t)
 329         ;; XEmacs moves point to the beginning of the buffer after
 330         ;; inserting a file, FSFmacs doesn't so if the fifth argument
 331         ;; of `insert-file-contents' is specified.
 332         (goto-char (point-min))
 333         ;;
 334         (while (progn
 335                  (while (and (looking-at "[\t\v\f\r ]*\\(;.*\\)?$")
 336                              (zerop (forward-line 1))))
 337                  (not (eobp)))
 338           (setcar lines (if (bolp)
 339                             (1+ (count-lines (point-min) (point)))
 340                           (count-lines (point-min) (point))))
 341           (when (consp;; Ignore stand-alone symbols, strings, etc.
 342                  (setq form (condition-case nil
 343                                 (read working)
 344                               (error nil))))
 345             (setcdr lines (list (count-lines (point-min) (point))))
 346             (setq forms (list form)
 347                   fns nil)
 348             (while forms
 349               (setq form (pop forms))
 350               (when (consp form)
 351                 (setq fn (pop form))
 352                 (cond ((memq fn '(apply mapatoms mapcar mapconcat
 353                                         mapextent symbol-function))
 354                        (if (consp (car form))
 355                            (when (memq (caar form) '(\` backquote quote))
 356                              (setcar form (cdar form)))
 357                          (setq form (cdr form))))
 358                       ((memq fn '(\` backquote quote))
 359                        (if report-symbols
 360                            (progn
 361                              (setq form (car form)
 362                                    newform nil)
 363                              (while form
 364                                (push (list (or (car-safe form) form))
 365                                      newform)
 366                                (setq form (cdr-safe form)))
 367                              (setq form (nreverse newform)))
 368                          (setq form nil)))
 369                       ((memq fn '(defadvice
 370                                    defmacro defsubst defun
 371                                    defmacro-maybe defmacro-maybe-cond
 372                                    defsubst-maybe defun-maybe
 373                                    defun-maybe-cond))
 374                        (setq form (cddr form)))
 375                       ((memq fn '(defalias lambda fset))
 376                        (setq form (cdr form)))
 377                       ((eq fn 'define-compiler-macro)
 378                        (setq form nil))
 379                       ((eq fn 'dolist)
 380                        (setcar form (cadar form)))
 381                       ((memq fn '(let let*))
 382                        (setq form
 383                              (append
 384                               (delq nil
 385                                     (mapcar
 386                                      (lambda (element)
 387                                        (when (and (consp element)
 388                                                   (consp (cadr element)))
 389                                          (cadr element)))
 390                                      (car form)))
 391                               (cdr form))))
 392                       ((eq fn 'sort)
 393                        (when (and (consp (cadr form))
 394                                   (memq (caadr form) '(\` backquote quote)))
 395                          (setcdr form (list (cdadr form)))))
 396                       ((and (memq fn clfns)
 397                             (listp form))
 398                        (push fn fns)))
 399                 (when (listp form)
 400                   (setq forms (append form forms)))))
 401             (when fns
 402               (if buffer
 403                   (set-buffer buffer)
 404                 (display-buffer
 405                  (setq buffer (get-buffer-create
 406                                (concat "*CL run-time functions in: "
 407                                        file-or-directory "*"))))
 408                 (set-buffer buffer)
 409                 (erase-buffer)
 410                 (setq window (get-buffer-window buffer t)
 411                       scroll (- 2 (window-height window))
 412                       fill-column (max 16 (- (window-width window) 2))
 413                       fill-prefix "               "))
 414               (when file
 415                 (insert file "\n")
 416                 (setq file nil))
 417               (narrow-to-region
 418                (point)
 419                (progn
 420                  (insert fill-prefix
 421                          (mapconcat (lambda (fn) (format "%s" fn))
 422                                     (nreverse fns) " ")
 423                          "\n")
 424                  (point)))
 425               (fill-region (point-min) (point-max))
 426               (goto-char (point-min))
 427               (widen)
 428               (delete-char 14)
 429               (insert (format "%5d - %5d:" (car lines) (cadr lines)))
 430               (goto-char (point-max))
 431               (forward-line scroll)
 432               (set-window-start window (point))
 433               (goto-char (point-max))
 434               (sit-for 0)
 435               (set-buffer working)))))
 436       (kill-buffer working)
 437       (if buffer
 438           (message "Done")
 439         (message "No CL run-time functions found in: %s"
 440                  file-or-directory)))))
 441
 442 (provide 'gnus-clfns)
 443
 444 ;;; gnus-clfns.el ends here