X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-clfns.el;h=8e2ba3f3a50304318cc837a17b0419a3f6a06539;hb=e5bec5d05f433a43fa2d14cdb7bebeeefab8835f;hp=c9257cda0ae6e02a956d04a588ef4d621d363c36;hpb=725c9ec02e68ef9791558369c24921ada8929b30;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-clfns.el b/lisp/gnus-clfns.el index c9257cd..8e2ba3f 100644 --- a/lisp/gnus-clfns.el +++ b/lisp/gnus-clfns.el @@ -31,7 +31,7 @@ (if (featurep 'xemacs) nil - (require 'cl) + (eval-when-compile (require 'cl)) (require 'pym) (define-compiler-macro butlast (&whole form x &optional n) @@ -176,6 +176,180 @@ res))))))))) ) +;; A tool for the developers. + +(defvar cl-run-time-functions + '(Values + Values-list acons assoc-if assoc-if-not build-klist butlast ceiling* + coerce common-lisp-indent-function compiler-macroexpand concatenate + copy-list count count-if count-if-not delete* delete-duplicates delete-if + delete-if-not duplicate-symbols-p elt-satisfies-test-p equalp evenp every + extract-from-klist fill find find-if find-if-not floatp-safe floor* gcd + gensym gentemp get-setf-method getf hash-table-count hash-table-p + intersection isqrt keyword-argument-supplied-p keyword-of keywordp last + lcm ldiff lisp-indent-259 lisp-indent-do lisp-indent-function-lambda-hack + lisp-indent-report-bad-format lisp-indent-tagbody list-length + make-hash-table make-random-state map mapc mapcan mapcar* mapcon mapl + maplist member-if member-if-not merge mismatch mod* nbutlast nintersection + notany notevery nreconc nset-difference nset-exclusive-or nsublis nsubst + nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not + nunion oddp pair-with-newsyms pairlis position position-if position-if-not + proclaim random* random-state-p rassoc* rassoc-if rassoc-if-not + reassemble-argslists reduce rem* remove remove* remove-duplicates + remove-if remove-if-not remq replace revappend round* safe-idiv search + set-difference set-exclusive-or setelt setnth setnthcdr signum some sort* + stable-sort sublis subseq subsetp subst subst-if subst-if-not substitute + substitute-if substitute-if-not tailp tree-equal truncate* union + unzip-lists zip-lists) + "A list of CL run-time functions. Some functions were built-in, nowadays.") + +;;;###autoload +(defun find-cl-run-time-functions (file-or-directory in-this-emacs) + "Find CL run-time functions in the FILE-OR-DIRECTORY. If the prefix +argument IN-THIS-EMACS is non-nil, the built-in functions in this +Emacs will not be reported." + (interactive (list (read-file-name "Find CL run-time functions in: " + nil default-directory t) + current-prefix-arg)) + (unless (interactive-p) + (error "You should invoke `M-x find-cl-run-time-functions' interactively")) + (let (files clfns working file lines forms fns pt form fn buffer + window height buffer-file-format format-alist + insert-file-contents-post-hook insert-file-contents-pre-hook) + (cond ((file-directory-p file-or-directory) + (prog1 + (setq files (directory-files file-or-directory t "\\.el$")) + (unless files + (message "No files found in: %s" file-or-directory)))) + ((file-exists-p file-or-directory) + (setq files (list file-or-directory))) + (t + (message "No such file or directory: %s" file-or-directory))) + (dolist (file files) + (unless (file-exists-p file) + (setq files (delete file files)))) + (if files + (progn + (if in-this-emacs + (dolist (fn cl-run-time-functions) + (unless (and (fboundp fn) + (subrp (symbol-function fn))) + (push fn clfns))) + (setq clfns cl-run-time-functions)) + (set-buffer (setq working + (get-buffer-create + " *Searching for CL run-time functions*"))) + (let (emacs-lisp-mode-hook) + (emacs-lisp-mode)) + (while files + (setq file (pop files) + lines (list nil 1)) + (message "Searching for CL run-time functions in: %s..." + (file-name-nondirectory file)) + (insert-file-contents file nil nil nil t) + ;; Why is the following needed for FSF Emacsen??? + (goto-char (point-min)) + ;; + (while (setq forms (condition-case nil + (list (read working)) + (error nil))) + (setq fns nil + pt (point) + lines (list (cadr lines) + (count-lines (point-min) pt))) + (condition-case nil + (progn + (forward-list -1) + (setcar lines (+ (count-lines (point-min) (point)) + (if (bolp) 1 0)))) + (error)) + (goto-char pt) + (while forms + (setq form (pop forms)) + (if (consp form) + (progn + (setq fn (pop form)) + (cond ((eq fn 'define-compiler-macro) + (setq form nil)) + ((memq fn '(let let*)) + (setq form + (append + (delq nil + (mapcar + (lambda (element) + (when (and (consp element) + (consp (cadr element))) + (cadr element))) + (car form))) + (cdr form)))) + ((memq fn '(defadvice + defmacro defsubst defun + defmacro-maybe defmacro-maybe-cond + defsubst-maybe defun-maybe + defun-maybe-cond)) + (setq form (cddr form))) + ((eq fn 'lambda) + (setq form (cdr form))) + ((memq fn '(\` backquote quote)) + (setq form (when (consp (car form)) + (car form)))) + ((eq fn 'dolist) + (setcar form (cadar form))) + ((and (memq fn clfns) + (listp form)) + (push fn fns))) + (when (and (consp form) + (condition-case nil + ;; Ignore a case `(a b . c)'. + (length form) + (error nil))) + (setq forms (append (delq nil + (mapcar + (lambda (element) + (when (consp element) + element)) + form)) + forms)))) + (goto-char (point-max)) + (setq lines (list (cadr lines) + (count-lines (point-min) (point))) + fns '("Couldn't parse, check this file manually.")))) + (when fns + (if buffer + (set-buffer buffer) + (display-buffer + (setq buffer (get-buffer-create + (concat "*CL run-time functions in: " + file-or-directory "*")))) + (setq window (get-buffer-window buffer t) + height (window-height window)) + (set-buffer buffer) + (erase-buffer)) + (when file + (insert file "\n") + (setq file nil)) + (insert (format "%5d - %5d: %s" + (car lines) (cadr lines) + (mapconcat (lambda (fn) (format "%s" fn)) + (nreverse fns) " "))) + (while (> (current-column) 78) + (skip-chars-backward "^ ") + (backward-char 1) + (insert "\n ") + (end-of-line)) + (insert "\n") + (when (zerop (forward-line (- 0 height -2))) + (set-window-start window (point))) + (goto-char (point-max)) + (sit-for 0) + (set-buffer working)))) + (kill-buffer working) + (if buffer + (message "Done") + (message "No CL run-time functions found in: %s" + file-or-directory))) + (message "No files found")))) + (provide 'gnus-clfns) ;;; gnus-clfns.el ends here