1 ;;; gnus-clfns.el --- compiler macros for emulating cl functions
3 ;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
5 ;; Author: Kastsumi Yamaoka <yamaoka@jpl.org>
6 ;; Keywords: cl, compile
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 ;; This module is for mainly avoiding cl runtime functions in FSF
28 ;; Emacsen. Function should also be defined as an ordinary function
29 ;; if it will not be provided in cl.
33 (if (featurep 'xemacs)
35 (eval-when-compile (require 'cl))
38 (define-compiler-macro butlast (&whole form x &optional n)
39 (if (and (fboundp 'butlast)
40 (subrp (symbol-function 'butlast)))
53 (setq x (copy-sequence x))
54 (setcdr (nthcdr (- (1- m) n) x) nil)))
60 (setq x (copy-sequence x))
61 (setcdr (nthcdr (- m 2) x) nil)
64 (define-compiler-macro coerce (&whole form x type)
65 (if (and (fboundp 'coerce)
66 (subrp (symbol-function 'coerce)))
70 (cond ((eq type 'list) (if (listp x) x (append x nil)))
71 ((eq type 'vector) (if (vectorp x) x (vconcat x)))
72 ((eq type 'string) (if (stringp x) x (concat x)))
73 ((eq type 'array) (if (arrayp x) x (vconcat x)))
74 ((and (eq type 'character) (stringp x) (= (length x) 1))
76 ((and (eq type 'character) (symbolp x)
77 (= (length (symbol-name x)) 1))
78 (aref (symbol-name x) 0))
79 ((eq type 'float) (float x))
81 (t (error "Can't coerce %s to type %s" x type))))))
83 (define-compiler-macro copy-list (&whole form list)
84 (if (and (fboundp 'copy-list)
85 (subrp (symbol-function 'copy-list)))
90 (while (consp list) (push (pop list) res))
91 (prog1 (nreverse res) (setcdr res list)))
94 (define-compiler-macro last (&whole form x &optional n)
95 (if (and (fboundp 'last)
96 (subrp (symbol-function 'last)))
112 (while (consp (cdr x))
116 (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
117 (if (and (fboundp 'merge)
118 (subrp (symbol-function 'merge)))
124 (or (listp seq1) (setq seq1 (append seq1 nil)))
125 (or (listp seq2) (setq seq2 (append seq2 nil)))
127 (while (and seq1 seq2)
128 (if (funcall pred (car seq2) (car seq1))
129 (push (pop seq2) res)
130 (push (pop seq1) res)))
131 (coerce (nconc (nreverse res) seq1 seq2) type)))))
133 (define-compiler-macro string (&whole form &rest args)
134 (if (and (fboundp 'string)
135 (subrp (symbol-function 'string)))
137 (list 'concat (cons 'list args))))
139 (defun-maybe string (&rest args)
140 "Concatenate all the argument characters and make the result a string."
143 (define-compiler-macro string-to-list (&whole form string)
144 (cond ((fboundp 'string-to-list)
146 ((fboundp 'string-to-char-list)
147 (list 'string-to-char-list string))
149 `(let* ((str ,string)
154 (setq c (sref str idx))
155 (setq idx (+ idx (char-bytes c)))
159 ;; 92.7.2 by K.Handa (imported from Mule 2.3)
160 (defun-maybe string-to-list (str)
161 (let ((len (length str))
165 (setq c (sref str idx))
166 (setq idx (+ idx (char-bytes c)))
170 (define-compiler-macro subseq (&whole form seq start &optional end)
171 (if (and (fboundp 'subseq)
172 (subrp (symbol-function 'subseq)))
179 (substring seq start end)
182 (setq end (+ end (setq len (length seq)))))
184 (setq start (+ start (or len (setq len (length seq))))))
187 (setq seq (nthcdr start seq)))
189 (while (>= (setq end (1- end)) start)
190 (push (pop seq) res))
193 (let ((res (make-vector (max (- end start) 0) nil))
196 (aset res i (aref seq start))
203 (substring seq start)
206 (setq start (+ start (or len (setq len (length seq))))))
209 (setq seq (nthcdr start seq)))
212 (let* ((end (or len (length seq)))
213 (res (make-vector (max (- end start) 0) nil))
216 (aset res i (aref seq start))
222 ;; A tool for the developers.
224 (defvar cl-run-time-functions
226 Values-list acons assoc-if assoc-if-not build-klist butlast ceiling*
227 coerce common-lisp-indent-function compiler-macroexpand concatenate
228 copy-list count count-if count-if-not delete* delete-duplicates delete-if
229 delete-if-not duplicate-symbols-p elt-satisfies-test-p equalp evenp every
230 extract-from-klist fill find find-if find-if-not floatp-safe floor* gcd
231 gensym gentemp get-setf-method getf hash-table-count hash-table-p
232 intersection isqrt keyword-argument-supplied-p keyword-of keywordp last
233 lcm ldiff lisp-indent-259 lisp-indent-do lisp-indent-function-lambda-hack
234 lisp-indent-report-bad-format lisp-indent-tagbody list-length
235 make-hash-table make-random-state map mapc mapcan mapcar* mapcon mapl
236 maplist member-if member-if-not merge mismatch mod* nbutlast nintersection
237 notany notevery nreconc nset-difference nset-exclusive-or nsublis nsubst
238 nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not
239 nunion oddp pair-with-newsyms pairlis position position-if position-if-not
240 proclaim random* random-state-p rassoc* rassoc-if rassoc-if-not
241 reassemble-argslists reduce rem* remove remove* remove-duplicates
242 remove-if remove-if-not remq replace revappend round* safe-idiv search
243 set-difference set-exclusive-or setelt setnth setnthcdr signum some sort*
244 stable-sort sublis subseq subsetp subst subst-if subst-if-not substitute
245 substitute-if substitute-if-not tailp tree-equal truncate* union
246 unzip-lists zip-lists)
247 "A list of CL run-time functions. Some functions were built-in, nowadays.")
250 (defun find-cl-run-time-functions (file-or-directory arg)
251 "Find CL run-time functions in the FILE-OR-DIRECTORY. You can alter
252 the behavior of this command with the prefix ARG as described below.
254 By default, it searches for all the CL run-time functions listed in
255 the variable `cl-run-time-functions'.
256 With 1 or 3 \\[universal-argument]'s, the built-in functions in this Emacs\
259 With 2 or 3 \\[universal-argument]'s, just the symbols will also be reported.
261 You can use the `digit-argument' 1, 2 or 3 instead of\
262 \\[universal-argument]'s."
263 (interactive (list (read-file-name "Find CL run-time functions in: "
264 nil default-directory t)
266 (unless (interactive-p)
267 (error "You should invoke `M-x find-cl-run-time-functions' interactively"))
268 (let ((report-symbols (member arg '((16) (64) 2 3)))
269 files clfns working file lines form forms fns fn newform buffer
271 buffer-file-format format-alist
272 insert-file-contents-post-hook insert-file-contents-pre-hook)
273 (cond ((file-directory-p file-or-directory)
274 (setq files (directory-files file-or-directory t "\\.el$"))
276 (unless (file-exists-p file)
277 (setq files (delete file files))))
279 (message "No files found in: %s" file-or-directory))
281 ((file-exists-p file-or-directory)
282 (setq files (list file-or-directory)))
284 (message "No such file or directory: %s" file-or-directory)))
286 (if (member arg '((4) (64) 1 3))
287 (dolist (fn cl-run-time-functions)
288 (unless (and (fboundp fn)
289 (subrp (symbol-function fn)))
291 (setq clfns cl-run-time-functions))
292 (set-buffer (setq working
294 " *Searching for CL run-time functions*")))
295 (let (emacs-lisp-mode-hook)
298 (setq file (pop files)
299 lines (list nil nil))
300 (message "Searching for CL run-time functions in: %s..."
301 (file-name-nondirectory file))
302 (insert-file-contents file nil nil nil t)
303 ;; XEmacs moves point to the beginning of the buffer after
304 ;; inserting a file, FSFmacs doesn't so if the fifth argument
305 ;; of `insert-file-contents' is specified.
306 (goto-char (point-min))
309 (while (and (looking-at "[\t\v\f\r ]*\\(;.*\\)?$")
310 (zerop (forward-line 1))))
312 (setcar lines (if (bolp)
313 (1+ (count-lines (point-min) (point)))
314 (count-lines (point-min) (point))))
315 (when (consp;; Ignore stand-alone symbols, strings, etc.
316 (setq form (condition-case nil
319 (setcdr lines (list (count-lines (point-min) (point))))
320 (setq forms (list form)
323 (setq form (pop forms))
326 (cond ((memq fn '(apply mapatoms mapcar mapconcat
327 mapextent symbol-function))
328 (if (consp (car form))
329 (when (memq (caar form) '(\` backquote quote))
330 (setcar form (cdar form)))
331 (setq form (cdr form))))
332 ((memq fn '(\` backquote quote))
335 (setq form (car form)
338 (push (list (or (car-safe form) form))
340 (setq form (cdr-safe form)))
341 (setq form (nreverse newform)))
343 ((memq fn '(defadvice
344 defmacro defsubst defun
345 defmacro-maybe defmacro-maybe-cond
346 defsubst-maybe defun-maybe
348 (setq form (cddr form)))
349 ((memq fn '(defalias lambda fset))
350 (setq form (cdr form)))
351 ((eq fn 'define-compiler-macro)
354 (setcar form (cadar form)))
355 ((memq fn '(let let*))
361 (when (and (consp element)
362 (consp (cadr element)))
367 (when (and (consp (cadr form))
368 (memq (caadr form) '(\` backquote quote)))
369 (setcdr form (list (cdadr form)))))
370 ((and (memq fn clfns)
374 (setq forms (append form forms)))))
379 (setq buffer (get-buffer-create
380 (concat "*CL run-time functions in: "
381 file-or-directory "*"))))
384 (setq window (get-buffer-window buffer t)
385 scroll (- 2 (window-height window))
386 fill-column (max 16 (- (window-width window) 2))
395 (mapconcat (lambda (fn) (format "%s" fn))
399 (fill-region (point-min) (point-max))
400 (goto-char (point-min))
403 (insert (format "%5d - %5d:" (car lines) (cadr lines)))
404 (goto-char (point-max))
405 (forward-line scroll)
406 (set-window-start window (point))
407 (goto-char (point-max))
409 (set-buffer working)))))
410 (kill-buffer working)
413 (message "No CL run-time functions found in: %s"
414 file-or-directory)))))
416 (provide 'gnus-clfns)
418 ;;; gnus-clfns.el ends here