X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-clfns.el;h=191db6d716af35cab4a48b546095bd7add0ac6ec;hb=9b741e050b400987d68ff761c6cc3276c932839c;hp=f3ee463572e0ddf8ec55ac696d79bdb0181c8899;hpb=1456ef4e518b2e30ae51bf23255c5ab16ef1fae5;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-clfns.el b/lisp/gnus-clfns.el
index f3ee463..191db6d 100644
--- a/lisp/gnus-clfns.el
+++ b/lisp/gnus-clfns.el
@@ -1,5 +1,6 @@
 ;;; gnus-clfns.el --- compiler macros for emulating cl functions
-;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
+
+;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
 
 ;; Author: Kastsumi Yamaoka <yamaoka@jpl.org>
 ;; Keywords: cl, compile
@@ -47,12 +48,16 @@
 		 (or n (setq n 1))
 		 (and (< n m)
 		      (progn
-			(if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
+			(if (> n 0)
+			    (progn
+			      (setq x (copy-sequence x))
+			      (setcdr (nthcdr (- (1- m) n) x) nil)))
 			x)))))
 	`(let* ((x ,x)
 		(m (length x)))
 	   (and (< 1 m)
 		(progn
+		  (setq x (copy-sequence x))
 		  (setcdr (nthcdr (- m 2) x) nil)
 		  x))))))
 
@@ -75,6 +80,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 +140,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)))
@@ -204,148 +247,171 @@
   "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."
+(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 (files clfns working giveup file lines forms fns pt form fn buffer
-	      buffer-file-format format-alist
-	      insert-file-contents-post-hook insert-file-contents-pre-hook)
+  (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)
-	   (prog1
-	       (setq files (directory-files file-or-directory t "\\.el$"))
-	     (unless files
-	       (message "No files found in: %s" 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)))
-    (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 giveup nil
-		  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 giveup t
-			lines (list (cadr lines)
-				    (count-lines (point-min) (point)))
-			fns '("Couldn't parse, check this file manually."))))
-	      (when (or fns giveup)
-		(if buffer
-		    (set-buffer buffer)
-		  (display-buffer
-		   (setq buffer (get-buffer-create
-				 (concat "*CL run-time functions in: "
-					 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)))
+		(when (listp form)
+		  (setq forms (append form forms)))))
+	    (when fns
+	      (if buffer
 		  (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")
-		(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"))))
+		(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) " ")
+			 "\n")
+		 (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)