X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-clfns.el;h=123b9b1512ac6d3f6b698b5821db25fd32c48b11;hb=36bd162f4f7cd40453b8683e796730836c352b2a;hp=c9257cda0ae6e02a956d04a588ef4d621d363c36;hpb=725c9ec02e68ef9791558369c24921ada8929b30;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-clfns.el b/lisp/gnus-clfns.el
index c9257cd..123b9b1 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)
@@ -75,6 +75,17 @@
 	       ((typep x type) x)
 	       (t (error "Can't coerce %s to type %s" x type))))))
 
+  (define-compiler-macro copy-list (&whole form list)
+    (if (and (fboundp 'copy-list)
+	     (subrp (symbol-function 'copy-list)))
+	form
+      `(let ((list ,list))
+	 (if (consp list)
+	     (let ((res nil))
+	       (while (consp list) (push (pop list) res))
+	       (prog1 (nreverse res) (setcdr res list)))
+	   (car list)))))
+
   (define-compiler-macro last (&whole form x &optional n)
     (if (and (fboundp 'last)
 	     (subrp (symbol-function 'last)))
@@ -124,6 +135,33 @@
     "Concatenate all the argument characters and make the result a string."
     (concat args))
 
+  (define-compiler-macro string-to-list (&whole form string)
+    (cond ((fboundp 'string-to-list)
+	   form)
+	  ((fboundp 'string-to-char-list)
+	   (list 'string-to-char-list string))
+	  (t
+	   `(let* ((str ,string)
+		   (len (length str))
+		   (idx 0)
+		   c l)
+	      (while (< idx len)
+		(setq c (sref str idx))
+		(setq idx (+ idx (char-bytes c)))
+		(setq l (cons c l)))
+	      (nreverse l)))))
+
+  ;; 92.7.2 by K.Handa (imported from Mule 2.3)
+  (defun-maybe string-to-list (str)
+    (let ((len (length str))
+	  (idx 0)
+	  c l)
+      (while (< idx len)
+	(setq c (sref str idx))
+	(setq idx (+ idx (char-bytes c)))
+	(setq l (cons c l)))
+      (nreverse l)))
+
   (define-compiler-macro subseq (&whole form seq start &optional end)
     (if (and (fboundp 'subseq)
 	     (subrp (symbol-function 'subseq)))
@@ -176,6 +214,198 @@
 			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 arg)
+  "Find CL run-time functions in the FILE-OR-DIRECTORY.  You can alter
+the behavior of this command with the prefix ARG as described below.
+
+By default, it searches for all the CL run-time functions listed in
+ the variable `cl-run-time-functions'.
+With 1 or 3 \\[universal-argument]'s, the built-in functions in this Emacs\
+ will not be
+ reported.
+With 2 or 3 \\[universal-argument]'s, just the symbols will also be reported.
+
+You can use the `digit-argument' 1, 2 or 3 instead of\
+ \\[universal-argument]'s."
+  (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 ((report-symbols (member arg '((16) (64) 2 3)))
+	files clfns working file lines form forms fns fn newform buffer
+	window scroll
+	buffer-file-format format-alist
+	insert-file-contents-post-hook insert-file-contents-pre-hook)
+    (cond ((file-directory-p file-or-directory)
+	   (setq files (directory-files file-or-directory t "\\.el$"))
+	   (dolist (file files)
+	     (unless (file-exists-p file)
+	       (setq files (delete file files))))
+	   (unless files
+	     (message "No files found in: %s" file-or-directory))
+	   files)
+	  ((file-exists-p file-or-directory)
+	   (setq files (list file-or-directory)))
+	  (t
+	   (message "No such file or directory: %s" file-or-directory)))
+    (when files
+      (if (member arg '((4) (64) 1 3))
+	  (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 nil))
+	(message "Searching for CL run-time functions in: %s..."
+		 (file-name-nondirectory file))
+	(insert-file-contents file nil nil nil t)
+	;; XEmacs moves point to the beginning of the buffer after
+	;; inserting a file, FSFmacs doesn't so if the fifth argument
+	;; of `insert-file-contents' is specified.
+	(goto-char (point-min))
+	;;
+	(while (progn
+		 (while (and (looking-at "[\t\v\f\r ]*\\(;.*\\)?$")
+			     (zerop (forward-line 1))))
+		 (not (eobp)))
+	  (setcar lines (if (bolp)
+			    (1+ (count-lines (point-min) (point)))
+			  (count-lines (point-min) (point))))
+	  (when (consp;; Ignore stand-alone symbols, strings, etc.
+		 (setq form (condition-case nil
+				(read working)
+			      (error nil))))
+	    (setcdr lines (list (count-lines (point-min) (point))))
+	    (setq forms (list form)
+		  fns nil)
+	    (while forms
+	      (setq form (pop forms))
+	      (when (consp form)
+		(setq fn (pop form))
+		(cond ((memq fn '(apply mapatoms mapcar mapconcat
+					mapextent symbol-function))
+		       (if (consp (car form))
+			   (when (memq (caar form) '(\` backquote quote))
+			     (setcar form (cdar form)))
+			 (setq form (cdr form))))
+		      ((memq fn '(\` backquote quote))
+		       (if report-symbols
+			   (progn
+			     (setq form (car form)
+				   newform nil)
+			     (while form
+			       (push (list (or (car-safe form) form))
+				     newform)
+			       (setq form (cdr-safe form)))
+			     (setq form (nreverse newform)))
+			 (setq form nil)))
+		      ((memq fn '(defadvice
+				   defmacro defsubst defun
+				   defmacro-maybe defmacro-maybe-cond
+				   defsubst-maybe defun-maybe
+				   defun-maybe-cond))
+		       (setq form (cddr form)))
+		      ((memq fn '(defalias lambda fset))
+		       (setq form (cdr form)))
+		      ((eq fn 'define-compiler-macro)
+		       (setq form nil))
+		      ((eq fn 'dolist)
+		       (setcar form (cadar form)))
+		      ((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))))
+		      ((eq fn 'sort)
+		       (when (and (consp (cadr form))
+				  (memq (caadr form) '(\` backquote quote)))
+			 (setcdr form (list (cdadr form)))))
+		      ((and (memq fn clfns)
+			    (listp form))
+		       (push fn fns)))
+		(setq forms (append form forms))))
+	    (when fns
+	      (if buffer
+		  (set-buffer buffer)
+		(display-buffer
+		 (setq buffer (get-buffer-create
+			       (concat "*CL run-time functions in: "
+				       file-or-directory "*"))))
+		(set-buffer buffer)
+		(erase-buffer)
+		(setq window (get-buffer-window buffer t)
+		      scroll (- 2 (window-height window))
+		      fill-column (max 16 (- (window-width window) 2))
+		      fill-prefix "               "))
+	      (when file
+		(insert file "\n")
+		(setq file nil))
+	      (narrow-to-region
+	       (point)
+	       (progn
+		 (insert fill-prefix
+			 (mapconcat (lambda (fn) (format "%s" fn))
+				    (nreverse fns) " "))
+		 (point)))
+	      (fill-region (point-min) (point-max))
+	      (goto-char (point-min))
+	      (widen)
+	      (delete-char 14)
+	      (insert (format "%5d - %5d:" (car lines) (cadr lines)))
+	      (goto-char (point-max))
+	      (forward-line scroll)
+	      (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)))))
+
 (provide 'gnus-clfns)
 
 ;;; gnus-clfns.el ends here