(if (featurep 'xemacs)
nil
- (require 'cl)
+ (eval-when-compile (require 'cl))
(require 'pym)
(define-compiler-macro butlast (&whole form x &optional n)
((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)))
"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)))
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