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 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 ;; A tool for the developers.
 180
 181 (defvar cl-run-time-functions
 182   '(Values
 183     Values-list acons assoc-if assoc-if-not build-klist butlast ceiling*
 184     coerce common-lisp-indent-function compiler-macroexpand concatenate
 185     copy-list count count-if count-if-not delete* delete-duplicates delete-if
 186     delete-if-not duplicate-symbols-p elt-satisfies-test-p equalp evenp every
 187     extract-from-klist fill find find-if find-if-not floatp-safe floor* gcd
 188     gensym gentemp get-setf-method getf hash-table-count hash-table-p
 189     intersection isqrt keyword-argument-supplied-p keyword-of keywordp last
 190     lcm ldiff lisp-indent-259 lisp-indent-do lisp-indent-function-lambda-hack
 191     lisp-indent-report-bad-format lisp-indent-tagbody list-length
 192     make-hash-table make-random-state map mapc mapcan mapcar* mapcon mapl
 193     maplist member-if member-if-not merge mismatch mod* nbutlast nintersection
 194     notany notevery nreconc nset-difference nset-exclusive-or nsublis nsubst
 195     nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not
 196     nunion oddp pair-with-newsyms pairlis position position-if position-if-not
 197     proclaim random* random-state-p rassoc* rassoc-if rassoc-if-not
 198     reassemble-argslists reduce rem* remove remove* remove-duplicates
 199     remove-if remove-if-not remq replace revappend round* safe-idiv search
 200     set-difference set-exclusive-or setelt setnth setnthcdr signum some sort*
 201     stable-sort sublis subseq subsetp subst subst-if subst-if-not substitute
 202     substitute-if substitute-if-not tailp tree-equal truncate* union
 203     unzip-lists zip-lists)
 204   "A list of CL run-time functions.  Some functions were built-in, nowadays.")
 205
 206 ;;;###autoload
 207 (defun find-cl-run-time-functions (file-or-directory in-this-emacs)
 208   "Find CL run-time functions in the FILE-OR-DIRECTORY.  If the prefix
 209 argument IN-THIS-EMACS is non-nil, the built-in functions in this
 210 Emacs will not be reported."
 211   (interactive (list (read-file-name "Find CL run-time functions in: "
 212                                      nil default-directory t)
 213                      current-prefix-arg))
 214   (unless (interactive-p)
 215     (error "You should invoke `M-x find-cl-run-time-functions' interactively"))
 216   (let (files clfns working file lines forms fns pt form fn buffer
 217               window height buffer-file-format format-alist
 218               insert-file-contents-post-hook insert-file-contents-pre-hook)
 219     (cond ((file-directory-p file-or-directory)
 220            (prog1
 221                (setq files (directory-files file-or-directory t "\\.el$"))
 222              (unless files
 223                (message "No files found in: %s" file-or-directory))))
 224           ((file-exists-p file-or-directory)
 225            (setq files (list file-or-directory)))
 226           (t
 227            (message "No such file or directory: %s" file-or-directory)))
 228     (dolist (file files)
 229       (unless (file-exists-p file)
 230         (setq files (delete file files))))
 231     (if files
 232         (progn
 233           (if in-this-emacs
 234               (dolist (fn cl-run-time-functions)
 235                 (unless (and (fboundp fn)
 236                              (subrp (symbol-function fn)))
 237                   (push fn clfns)))
 238             (setq clfns cl-run-time-functions))
 239           (set-buffer (setq working
 240                             (get-buffer-create
 241                              " *Searching for CL run-time functions*")))
 242           (let (emacs-lisp-mode-hook)
 243             (emacs-lisp-mode))
 244           (while files
 245             (setq file (pop files)
 246                   lines (list nil 1))
 247             (message "Searching for CL run-time functions in: %s..."
 248                      (file-name-nondirectory file))
 249             (insert-file-contents file nil nil nil t)
 250             ;; Why is the following needed for FSF Emacsen???
 251             (goto-char (point-min))
 252             ;;
 253             (while (setq forms (condition-case nil
 254                                    (list (read working))
 255                                  (error nil)))
 256               (setq fns nil
 257                     pt (point)
 258                     lines (list (cadr lines)
 259                                 (count-lines (point-min) pt)))
 260               (condition-case nil
 261                   (progn
 262                     (forward-list -1)
 263                     (setcar lines (+ (count-lines (point-min) (point))
 264                                      (if (bolp) 1 0))))
 265                 (error))
 266               (goto-char pt)
 267               (while forms
 268                 (setq form (pop forms))
 269                 (if (consp form)
 270                     (progn
 271                       (setq fn (pop form))
 272                       (cond ((eq fn 'define-compiler-macro)
 273                              (setq form nil))
 274                             ((memq fn '(let let*))
 275                              (setq form
 276                                    (append
 277                                     (delq nil
 278                                           (mapcar
 279                                            (lambda (element)
 280                                              (when (and (consp element)
 281                                                         (consp (cadr element)))
 282                                                (cadr element)))
 283                                            (car form)))
 284                                     (cdr form))))
 285                             ((memq fn '(defadvice
 286                                          defmacro defsubst defun
 287                                          defmacro-maybe defmacro-maybe-cond
 288                                          defsubst-maybe defun-maybe
 289                                          defun-maybe-cond))
 290                              (setq form (cddr form)))
 291                             ((eq fn 'lambda)
 292                              (setq form (cdr form)))
 293                             ((memq fn '(\` backquote quote))
 294                              (setq form (when (consp (car form))
 295                                           (car form))))
 296                             ((eq fn 'dolist)
 297                              (setcar form (cadar form)))
 298                             ((and (memq fn clfns)
 299                                   (listp form))
 300                              (push fn fns)))
 301                       (when (and (consp form)
 302                                  (condition-case nil
 303                                      ;; Ignore a case `(a b . c)'.
 304                                      (length form)
 305                                    (error nil)))
 306                         (setq forms (append (delq nil
 307                                                   (mapcar
 308                                                    (lambda (element)
 309                                                      (when (consp element)
 310                                                        element))
 311                                                    form))
 312                                             forms))))
 313                   (goto-char (point-max))
 314                   (setq lines (list (cadr lines)
 315                                     (count-lines (point-min) (point)))
 316                         fns '("Couldn't parse, check this file manually."))))
 317               (when fns
 318                 (if buffer
 319                     (set-buffer buffer)
 320                   (display-buffer
 321                    (setq buffer (get-buffer-create
 322                                  (concat "*CL run-time functions in: "
 323                                          file-or-directory "*"))))
 324                   (setq window (get-buffer-window buffer t)
 325                         height (window-height window))
 326                   (set-buffer buffer)
 327                   (erase-buffer))
 328                 (when file
 329                   (insert file "\n")
 330                   (setq file nil))
 331                 (insert (format "%5d - %5d: %s"
 332                                 (car lines) (cadr lines)
 333                                 (mapconcat (lambda (fn) (format "%s" fn))
 334                                            (nreverse fns) " ")))
 335                 (while (> (current-column) 78)
 336                   (skip-chars-backward "^ ")
 337                   (backward-char 1)
 338                   (insert "\n              ")
 339                   (end-of-line))
 340                 (insert "\n")
 341                 (when (zerop (forward-line (- 0 height -2)))
 342                   (set-window-start window (point)))
 343                 (goto-char (point-max))
 344                 (sit-for 0)
 345                 (set-buffer working))))
 346           (kill-buffer working)
 347           (if buffer
 348               (message "Done")
 349             (message "No CL run-time functions found in: %s"
 350                      file-or-directory)))
 351       (message "No files found"))))
 352
 353 (provide 'gnus-clfns)
 354
 355 ;;; gnus-clfns.el ends here