X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-clfns.el;fp=lisp%2Fgnus-clfns.el;h=0000000000000000000000000000000000000000;hb=85d086dab13c7c38268afe018a6fb28b45c1a0b5;hp=123b9b1512ac6d3f6b698b5821db25fd32c48b11;hpb=509a8e7082aea415f157fae31ccac13b8c68ed4f;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-clfns.el b/lisp/gnus-clfns.el
deleted file mode 100644
index 123b9b1..0000000
--- a/lisp/gnus-clfns.el
+++ /dev/null
@@ -1,411 +0,0 @@
-;;; gnus-clfns.el --- compiler macros for emulating cl functions
-;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
-
-;; Author: Kastsumi Yamaoka <yamaoka@jpl.org>
-;; Keywords: cl, compile
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This module is for mainly avoiding cl runtime functions in FSF
-;; Emacsen.  Function should also be defined as an ordinary function
-;; if it will not be provided in cl.
-
-;;; Code:
-
-(if (featurep 'xemacs)
-    nil
-  (eval-when-compile (require 'cl))
-  (require 'pym)
-
-  (define-compiler-macro butlast (&whole form x &optional n)
-    (if (and (fboundp 'butlast)
-	     (subrp (symbol-function 'butlast)))
-	form
-      (if n
-	  `(let ((x ,x)
-		 (n ,n))
-	     (if (and n (<= n 0))
-		 x
-	       (let ((m (length x)))
-		 (or n (setq n 1))
-		 (and (< n m)
-		      (progn
-			(if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
-			x)))))
-	`(let* ((x ,x)
-		(m (length x)))
-	   (and (< 1 m)
-		(progn
-		  (setcdr (nthcdr (- m 2) x) nil)
-		  x))))))
-
-  (define-compiler-macro coerce (&whole form x type)
-    (if (and (fboundp 'coerce)
-	     (subrp (symbol-function 'coerce)))
-	form
-      `(let ((x ,x)
-	     (type ,type))
-	 (cond ((eq type 'list) (if (listp x) x (append x nil)))
-	       ((eq type 'vector) (if (vectorp x) x (vconcat x)))
-	       ((eq type 'string) (if (stringp x) x (concat x)))
-	       ((eq type 'array) (if (arrayp x) x (vconcat x)))
-	       ((and (eq type 'character) (stringp x) (= (length x) 1))
-		(aref x 0))
-	       ((and (eq type 'character) (symbolp x)
-		     (= (length (symbol-name x)) 1))
-		(aref (symbol-name x) 0))
-	       ((eq type 'float) (float x))
-	       ((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)))
-	form
-      (if n
-	  `(let* ((x ,x)
-		  (n ,n)
-		  (m 0)
-		  (p x))
-	     (while (consp p)
-	       (incf m)
-	       (pop p))
-	     (if (<= n 0)
-		 p
-	       (if (< n m)
-		   (nthcdr (- m n) x)
-		 x)))
-	`(let ((x ,x))
-	   (while (consp (cdr x))
-	     (pop x))
-	   x))))
-
-  (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
-    (if (and (fboundp 'merge)
-	     (subrp (symbol-function 'merge)))
-	form
-      `(let ((type ,type)
-	     (seq1 ,seq1)
-	     (seq2 ,seq2)
-	     (pred ,pred))
-	 (or (listp seq1) (setq seq1 (append seq1 nil)))
-	 (or (listp seq2) (setq seq2 (append seq2 nil)))
-	 (let ((res nil))
-	   (while (and seq1 seq2)
-	     (if (funcall pred (car seq2) (car seq1))
-		 (push (pop seq2) res)
-	       (push (pop seq1) res)))
-	   (coerce (nconc (nreverse res) seq1 seq2) type)))))
-
-  (define-compiler-macro string (&whole form &rest args)
-    (if (and (fboundp 'string)
-	     (subrp (symbol-function 'string)))
-	form
-      (list 'concat (cons 'list args))))
-
-  (defun-maybe string (&rest args)
-    "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)))
-	form
-      (if end
-	  `(let ((seq ,seq)
-		 (start ,start)
-		 (end ,end))
-	     (if (stringp seq)
-		 (substring seq start end)
-	       (let (len)
-		 (if (< end 0)
-		     (setq end (+ end (setq len (length seq)))))
-		 (if (< start 0)
-		     (setq start (+ start (or len (setq len (length seq))))))
-		 (cond ((listp seq)
-			(if (> start 0)
-			    (setq seq (nthcdr start seq)))
-			(let ((res nil))
-			  (while (>= (setq end (1- end)) start)
-			    (push (pop seq) res))
-			  (nreverse res)))
-		       (t
-			(let ((res (make-vector (max (- end start) 0) nil))
-			      (i 0))
-			  (while (< start end)
-			    (aset res i (aref seq start))
-			    (setq i (1+ i)
-				  start (1+ start)))
-			  res))))))
-	`(let ((seq ,seq)
-	       (start ,start))
-	   (if (stringp seq)
-	       (substring seq start)
-	     (let (len)
-	       (if (< start 0)
-		   (setq start (+ start (or len (setq len (length seq))))))
-	       (cond ((listp seq)
-		      (if (> start 0)
-			  (setq seq (nthcdr start seq)))
-		      (copy-sequence seq))
-		     (t
-		      (let* ((end (or len (length seq)))
-			     (res (make-vector (max (- end start) 0) nil))
-			     (i 0))
-			(while (< start end)
-			  (aset res i (aref seq start))
-			  (setq i (1+ i)
-				start (1+ start)))
-			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