((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)))
"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 optional
-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 file forms fns pt lines form fn buffer
- buffer-file-format format-alist
- insert-file-contents-post-hook insert-file-contents-pre-hook
- jam-zcat-filename-list jka-compr-compression-info-list)
+ (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)))
- (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)))
- (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)
- 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))))
+ (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))
+ defmacro defsubst defun
+ defmacro-maybe defmacro-maybe-cond
+ defsubst-maybe defun-maybe
+ defun-maybe-cond))
(setq form (cddr form)))
- ((eq fn 'lambda)
+ ((memq fn '(defalias lambda fset))
(setq form (cdr form)))
- ((memq fn '(\` backquote quote))
- (setq form (when (consp (car form))
- (car 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 (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))))
- (when fns
- (if buffer
- (set-buffer buffer)
- (display-buffer
- (setq buffer (get-buffer-create
- (concat "*CL run-time functions in: "
- file-or-directory "*"))))
+ (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 'symbol-name
- (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) " "))
+ (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)
projects / elisp / gnus.git- / blobdiff