mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-11 09:20:51 +00:00
Code Issues Releases Activity

* lisp/emacs-lisp/cl-lib.el: Rename from cl.el.

Browse Source 
* lisp/emacs-lisp/cl.el: New compatibility file.
* emacs-lisp/cl-lib.el, lisp/emacs-lisp/cl-seq.el, lisp/emacs-lisp/cl-macs.el:
* lisp/emacs-lisp/cl-extra.el: Rename all top-level functions and variables
to obey the "cl-" prefix.
* lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Adjust to new name.
This commit is contained in:
Stefan Monnier 2012-06-03 21:05:17 -04:00
parent 418cd7265a
commit 7c1898a7b9
8 changed files with 1914 additions and 1569 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
etc/NEWS
View File

@ -119,6 +119,18 @@ character when doing minibuffer filename prompts.
* Changes in Specialized Modes and Packages in Emacs 24.2
** CL's main entry is now (require 'cl-lib).
`cl-lib' is like the old `cl' except that it uses the namespace cleanly,
i.e. all its definitions have the "cl-" prefix.
If `cl' provided a feature under the name `foo', then `cl-lib' provides it
under the name `cl-foo' instead, with the exceptions of the few definitions
that had to use `foo*' to avoid conflicts with pre-existing Elisp entities,
which have not been renamed to `cl-foo*' but just `cl-foo'.
The old `cl' is now deprecated and is nothing more than a bunch of aliases that
provide the old non-prefixed names.
** VHDL-mode
- Support for ghdl (free vhdl compiler). Now default.
- Add/update support for VHDL-AMS packages.

17
lisp/ChangeLog
View File

@ -1,3 +1,12 @@
2012-06-04 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl-lib.el: Rename from cl.el.
* emacs-lisp/cl.el: New compatibility file.
* emacs-lisp/cl-lib.el, emacs-lisp/cl-seq.el, emacs-lisp/cl-macs.el:
* emacs-lisp/cl-extra.el: Rename all top-level functions and variables
to obey the "cl-" prefix.
* emacs-lisp/macroexp.el (macroexpand-all-1): Adjust to new name.
2012-06-03 Glenn Morris <rgm@gnu.org>
* emacs-lisp/authors.el (authors-aliases): Addition.
@ -18,14 +27,14 @@
2012-06-03 Chong Yidong <cyd@gnu.org>
* progmodes/compile.el (compilation-mode-line-fail)
(compilation-mode-line-run, compilation-mode-line-exit): New
faces.
(compilation-mode-line-run, compilation-mode-line-exit):
New faces.
(compilation-start, compilation-handle-exit): Use them (Bug#11032).
2012-06-03 Jack Duthen <duthen.mac.01@gmail.com> (tiny change)
* progmodes/which-func.el (which-func-update-ediff-windows): New
function. Use it in ediff-select-hook (Bug#11478).
* progmodes/which-func.el (which-func-update-ediff-windows):
New function. Use it in ediff-select-hook (Bug#11478).
2012-06-03 Chong Yidong <cyd@gnu.org>

206
lisp/emacs-lisp/cl-extra.el
View File

@ -37,12 +37,12 @@
;;; Code:
(require 'cl)
(require 'cl-lib)
;;; Type coercion.
;;;###autoload
(defun coerce (x type)
(defun cl-coerce (x type)
"Coerce OBJECT to type TYPE.
TYPE is a Common Lisp type specifier.
\n(fn OBJECT TYPE)"
@ -51,16 +51,16 @@ TYPE is a Common Lisp type specifier.
((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)) (coerce (symbol-name x) type))
((and (eq type 'character) (symbolp x)) (cl-coerce (symbol-name x) type))
((eq type 'float) (float x))
((typep x type) x)
((cl-typep x type) x)
(t (error "Can't coerce %s to type %s" x type))))
;;; Predicates.
;;;###autoload
(defun equalp (x y)
(defun cl-equalp (x y)
"Return t if two Lisp objects have similar structures and contents.
This is like `equal', except that it accepts numerically equal
numbers of different types (float vs. integer), and also compares
@ -73,14 +73,14 @@ strings case-insensitively."
((numberp x)
(and (numberp y) (= x y)))
((consp x)
(while (and (consp x) (consp y) (equalp (car x) (car y)))
(while (and (consp x) (consp y) (cl-equalp (car x) (car y)))
(setq x (cdr x) y (cdr y)))
(and (not (consp x)) (equalp x y)))
(and (not (consp x)) (cl-equalp x y)))
((vectorp x)
(and (vectorp y) (= (length x) (length y))
(let ((i (length x)))
(while (and (>= (setq i (1- i)) 0)
(equalp (aref x i) (aref y i))))
(cl-equalp (aref x i) (aref y i))))
(< i 0))))
(t (equal x y))))
@ -115,21 +115,21 @@ strings case-insensitively."
(cl-i -1))
(while (< (setq cl-i (1+ cl-i)) cl-n)
(push (funcall cl-func
(if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
(if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
cl-res)))
(if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
(if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
cl-res)))
(nreverse cl-res))))
;;;###autoload
(defun map (cl-type cl-func cl-seq &rest cl-rest)
(defun cl-map (cl-type cl-func cl-seq &rest cl-rest)
"Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
TYPE is the sequence type to return.
\n(fn TYPE FUNCTION SEQUENCE...)"
(let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
(and cl-type (coerce cl-res cl-type))))
(let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest)))
(and cl-type (cl-coerce cl-res cl-type))))
;;;###autoload
(defun maplist (cl-func cl-list &rest cl-rest)
(defun cl-maplist (cl-func cl-list &rest cl-rest)
"Map FUNCTION to each sublist of LIST or LISTs.
Like `mapcar', except applies to lists and their cdr's rather than to
the elements themselves.
@ -153,40 +153,40 @@ the elements themselves.
"Like `mapcar', but does not accumulate values returned by the function.
\n(fn FUNCTION SEQUENCE...)"
(if cl-rest
(progn (apply 'map nil cl-func cl-seq cl-rest)
(progn (apply 'cl-map nil cl-func cl-seq cl-rest)
cl-seq)
(mapc cl-func cl-seq)))
;;;###autoload
(defun mapl (cl-func cl-list &rest cl-rest)
"Like `maplist', but does not accumulate values returned by the function.
(defun cl-mapl (cl-func cl-list &rest cl-rest)
"Like `cl-maplist', but does not accumulate values returned by the function.
\n(fn FUNCTION LIST...)"
(if cl-rest
(apply 'maplist cl-func cl-list cl-rest)
(apply 'cl-maplist cl-func cl-list cl-rest)
(let ((cl-p cl-list))
(while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
cl-list)
;;;###autoload
(defun mapcan (cl-func cl-seq &rest cl-rest)
(defun cl-mapcan (cl-func cl-seq &rest cl-rest)
"Like `mapcar', but nconc's together the values returned by the function.
\n(fn FUNCTION SEQUENCE...)"
(apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
(apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest)))
;;;###autoload
(defun mapcon (cl-func cl-list &rest cl-rest)
"Like `maplist', but nconc's together the values returned by the function.
(defun cl-mapcon (cl-func cl-list &rest cl-rest)
"Like `cl-maplist', but nconc's together the values returned by the function.
\n(fn FUNCTION LIST...)"
(apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
(apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest)))
;;;###autoload
(defun some (cl-pred cl-seq &rest cl-rest)
(defun cl-some (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is true of any element of SEQ or SEQs.
If so, return the true (non-nil) value returned by PREDICATE.
\n(fn PREDICATE SEQ...)"
(if (or cl-rest (nlistp cl-seq))
(catch 'cl-some
(apply 'map nil
(apply 'cl-map nil
(function (lambda (&rest cl-x)
(let ((cl-res (apply cl-pred cl-x)))
(if cl-res (throw 'cl-some cl-res)))))
@ -196,12 +196,12 @@ If so, return the true (non-nil) value returned by PREDICATE.
cl-x)))
;;;###autoload
(defun every (cl-pred cl-seq &rest cl-rest)
(defun cl-every (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is true of every element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
(if (or cl-rest (nlistp cl-seq))
(catch 'cl-every
(apply 'map nil
(apply 'cl-map nil
(function (lambda (&rest cl-x)
(or (apply cl-pred cl-x) (throw 'cl-every nil))))
cl-seq cl-rest) t)
@ -210,18 +210,18 @@ If so, return the true (non-nil) value returned by PREDICATE.
(null cl-seq)))
;;;###autoload
(defun notany (cl-pred cl-seq &rest cl-rest)
(defun cl-notany (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of every element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
(not (apply 'some cl-pred cl-seq cl-rest)))
(not (apply 'cl-some cl-pred cl-seq cl-rest)))
;;;###autoload
(defun notevery (cl-pred cl-seq &rest cl-rest)
(defun cl-notevery (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of some element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
(not (apply 'every cl-pred cl-seq cl-rest)))
(not (apply 'cl-every cl-pred cl-seq cl-rest)))
;;; Support for `loop'.
;;; Support for `cl-loop'.
;;;###autoload
(defalias 'cl-map-keymap 'map-keymap)
@ -309,7 +309,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(setq cl-ovl (cdr cl-ovl))))
(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
;;; Support for `setf'.
;;; Support for `cl-setf'.
;;;###autoload
(defun cl-set-frame-visible-p (frame val)
(cond ((null val) (make-frame-invisible frame))
@ -317,7 +317,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(t (make-frame-visible frame)))
val)
;;; Support for `progv'.
;;; Support for `cl-progv'.
(defvar cl-progv-save)
;;;###autoload
(defun cl-progv-before (syms values)
@ -340,7 +340,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
;;; Numbers.
;;;###autoload
(defun gcd (&rest args)
(defun cl-gcd (&rest args)
"Return the greatest common divisor of the arguments."
(let ((a (abs (or (pop args) 0))))
(while args
@ -349,18 +349,18 @@ If so, return the true (non-nil) value returned by PREDICATE.
a))
;;;###autoload
(defun lcm (&rest args)
(defun cl-lcm (&rest args)
"Return the least common multiple of the arguments."
(if (memq 0 args)
0
(let ((a (abs (or (pop args) 1))))
(while args
(let ((b (abs (pop args))))
(setq a (* (/ a (gcd a b)) b))))
(setq a (* (/ a (cl-gcd a b)) b))))
a)))
;;;###autoload
(defun isqrt (x)
(defun cl-isqrt (x)
"Return the integer square root of the argument."
(if (and (integerp x) (> x 0))
(let ((g (cond ((<= x 100) 10) ((<= x 10000) 100)
@ -372,35 +372,35 @@ If so, return the true (non-nil) value returned by PREDICATE.
(if (eq x 0) 0 (signal 'arith-error nil))))
;;;###autoload
(defun floor* (x &optional y)
(defun cl-floor (x &optional y)
"Return a list of the floor of X and the fractional part of X.
With two arguments, return floor and remainder of their quotient."
(let ((q (floor x y)))
(list q (- x (if y (* y q) q)))))
;;;###autoload
(defun ceiling* (x &optional y)
(defun cl-ceiling (x &optional y)
"Return a list of the ceiling of X and the fractional part of X.
With two arguments, return ceiling and remainder of their quotient."
(let ((res (floor* x y)))
(let ((res (cl-floor x y)))
(if (= (car (cdr res)) 0) res
(list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
;;;###autoload
(defun truncate* (x &optional y)
(defun cl-truncate (x &optional y)
"Return a list of the integer part of X and the fractional part of X.
With two arguments, return truncation and remainder of their quotient."
(if (eq (>= x 0) (or (null y) (>= y 0)))
(floor* x y) (ceiling* x y)))
(cl-floor x y) (cl-ceiling x y)))
;;;###autoload
(defun round* (x &optional y)
(defun cl-round (x &optional y)
"Return a list of X rounded to the nearest integer and the remainder.
With two arguments, return rounding and remainder of their quotient."
(if y
(if (and (integerp x) (integerp y))
(let* ((hy (/ y 2))
(res (floor* (+ x hy) y)))
(res (cl-floor (+ x hy) y)))
(if (and (= (car (cdr res)) 0)
(= (+ hy hy) y)
(/= (% (car res) 2) 0))
@ -413,17 +413,17 @@ With two arguments, return rounding and remainder of their quotient."
(list q (- x q))))))
;;;###autoload
(defun mod* (x y)
(defun cl-mod (x y)
"The remainder of X divided by Y, with the same sign as Y."
(nth 1 (floor* x y)))
(nth 1 (cl-floor x y)))
;;;###autoload
(defun rem* (x y)
(defun cl-rem (x y)
"The remainder of X divided by Y, with the same sign as X."
(nth 1 (truncate* x y)))
(nth 1 (cl-truncate x y)))
;;;###autoload
(defun signum (x)
(defun cl-signum (x)
"Return 1 if X is positive, -1 if negative, 0 if zero."
(cond ((> x 0) 1) ((< x 0) -1) (t 0)))
@ -431,7 +431,7 @@ With two arguments, return rounding and remainder of their quotient."
;; Random numbers.
;;;###autoload
(defun random* (lim &optional state)
(defun cl-random (lim &optional state)
"Return a random nonnegative number less than LIM, an integer or float.
Optional second arg STATE is a random-state object."
(or state (setq state cl--random-state))
@ -443,29 +443,29 @@ Optional second arg STATE is a random-state object."
(aset vec 0 j)
(while (> (setq i (% (+ i 21) 55)) 0)
(aset vec i (setq j (prog1 k (setq k (- j k))))))
(while (< (setq i (1+ i)) 200) (random* 2 state))))
(while (< (setq i (1+ i)) 200) (cl-random 2 state))))
(let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
(j (aset state 2 (% (1+ (aref state 2)) 55)))
(n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
(if (integerp lim)
(if (<= lim 512) (% n lim)
(if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state))))
(if (> lim 8388607) (setq n (+ (lsh n 9) (cl-random 512 state))))
(let ((mask 1023))
(while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
(if (< (setq n (logand n mask)) lim) n (random* lim state))))
(if (< (setq n (logand n mask)) lim) n (cl-random lim state))))
(* (/ n '8388608e0) lim)))))
;;;###autoload
(defun make-random-state (&optional state)
(defun cl-make-random-state (&optional state)
"Return a copy of random-state STATE, or of the internal state if omitted.
If STATE is t, return a new state object seeded from the time of day."
(cond ((null state) (make-random-state cl--random-state))
(cond ((null state) (cl-make-random-state cl--random-state))
((vectorp state) (cl-copy-tree state t))
((integerp state) (vector 'cl-random-state-tag -1 30 state))
(t (make-random-state (cl-random-time)))))
(t (cl-make-random-state (cl-random-time)))))
;;;###autoload
(defun random-state-p (object)
(defun cl-random-state-p (object)
"Return t if OBJECT is a random-state object."
(and (vectorp object) (= (length object) 4)
(eq (aref object 0) 'cl-random-state-tag)))
@ -482,48 +482,48 @@ If STATE is t, return a new state object seeded from the time of day."
;;;###autoload
(defun cl-float-limits ()
"Initialize the Common Lisp floating-point parameters.
This sets the values of: `most-positive-float', `most-negative-float',
`least-positive-float', `least-negative-float', `float-epsilon',
`float-negative-epsilon', `least-positive-normalized-float', and
`least-negative-normalized-float'."
(or most-positive-float (not (numberp '2e1))
This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
`cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon',
`cl-float-negative-epsilon', `cl-least-positive-normalized-float', and
`cl-least-negative-normalized-float'."
(or cl-most-positive-float (not (numberp '2e1))
(let ((x '2e0) y z)
;; Find maximum exponent (first two loops are optimizations)
(while (cl-finite-do '* x x) (setq x (* x x)))
(while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
(while (cl-finite-do '+ x x) (setq x (+ x x)))
(setq z x y (/ x 2))
;; Now fill in 1's in the mantissa.
;; Now cl-fill in 1's in the mantissa.
(while (and (cl-finite-do '+ x y) (/= (+ x y) x))
(setq x (+ x y) y (/ y 2)))
(setq most-positive-float x
most-negative-float (- x))
(setq cl-most-positive-float x
cl-most-negative-float (- x))
;; Divide down until mantissa starts rounding.
(setq x (/ x z) y (/ 16 z) x (* x y))
(while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
(arith-error nil))
(setq x (/ x 2) y (/ y 2)))
(setq least-positive-normalized-float y
least-negative-normalized-float (- y))
(setq cl-least-positive-normalized-float y
cl-least-negative-normalized-float (- y))
;; Divide down until value underflows to zero.
(setq x (/ 1 z) y x)
(while (condition-case err (> (/ x 2) 0) (arith-error nil))
(setq x (/ x 2)))
(setq least-positive-float x
least-negative-float (- x))
(setq cl-least-positive-float x
cl-least-negative-float (- x))
(setq x '1e0)
(while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
(setq float-epsilon (* x 2))
(setq cl-float-epsilon (* x 2))
(setq x '1e0)
(while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
(setq float-negative-epsilon (* x 2))))
(setq cl-float-negative-epsilon (* x 2))))
nil)
;;; Sequence functions.
;;;###autoload
(defun subseq (seq start &optional end)
(defun cl-subseq (seq start &optional end)
"Return the subsequence of SEQ from START to END.
If END is omitted, it defaults to the length of the sequence.
If START or END is negative, it counts from the end."
@ -549,7 +549,7 @@ If START or END is negative, it counts from the end."
res))))))
;;;###autoload
(defun concatenate (type &rest seqs)
(defun cl-concatenate (type &rest seqs)
"Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
\n(fn TYPE SEQUENCE...)"
(cond ((eq type 'vector) (apply 'vconcat seqs))
@ -561,17 +561,17 @@ If START or END is negative, it counts from the end."
;;; List functions.
;;;###autoload
(defun revappend (x y)
(defun cl-revappend (x y)
"Equivalent to (append (reverse X) Y)."
(nconc (reverse x) y))
;;;###autoload
(defun nreconc (x y)
(defun cl-nreconc (x y)
"Equivalent to (nconc (nreverse X) Y)."
(nconc (nreverse x) y))
;;;###autoload
(defun list-length (x)
(defun cl-list-length (x)
"Return the length of list X. Return nil if list is circular."
(let ((n 0) (fast x) (slow x))
(while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
@ -579,7 +579,7 @@ If START or END is negative, it counts from the end."
(if fast (if (cdr fast) nil (1+ n)) n)))
;;;###autoload
(defun tailp (sublist list)
(defun cl-tailp (sublist list)
"Return true if SUBLIST is a tail of LIST."
(while (and (consp list) (not (eq sublist list)))
(setq list (cdr list)))
@ -591,7 +591,7 @@ If START or END is negative, it counts from the end."
;;; Property lists.
;;;###autoload
(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el
(defun cl-get (sym tag &optional def) ; See compiler macro in cl-macs.el
"Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
\n(fn SYMBOL PROPNAME &optional DEFAULT)"
(or (get sym tag)
@ -602,14 +602,14 @@ If START or END is negative, it counts from the end."
(if plist (car (cdr plist)) def)))))
;;;###autoload
(defun getf (plist tag &optional def)
(defun cl-getf (plist tag &optional def)
"Search PROPLIST for property PROPNAME; return its value or DEFAULT.
PROPLIST is a list of the sort returned by `symbol-plist'.
\n(fn PROPLIST PROPNAME &optional DEFAULT)"
(setplist '--cl-getf-symbol-- plist)
(or (get '--cl-getf-symbol-- tag)
;; Originally we called get* here,
;; but that fails, because get* has a compiler macro
;; Originally we called cl-get here,
;; but that fails, because cl-get has a compiler macro
;; definition that uses getf!
(when def
(while (and plist (not (eq (car plist) tag)))
@ -620,7 +620,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(defun cl-set-getf (plist tag val)
(let ((p plist))
(while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
(if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
(if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist))))
;;;###autoload
(defun cl-do-remf (plist tag)
@ -636,10 +636,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(if (and plist (eq tag (car plist)))
(progn (setplist sym (cdr (cdr plist))) t)
(cl-do-remf plist tag))))
;;;###autoload
(defalias 'remprop 'cl-remprop)
;;; Hash tables.
;; This is just kept for compatibility with code byte-compiled by Emacs-20.
@ -723,7 +719,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
This also does some trivial optimizations to make the form prettier."
(while (or (not (eq form (setq form (macroexpand form env))))
(and cl-macroexpand-cmacs
(not (eq form (setq form (compiler-macroexpand form)))))))
(not (eq form (setq form (cl-compiler-macroexpand form)))))))
(cond ((not (consp form)) form)
((memq (car form) '(let let*))
(if (null (nth 1 form))
@ -738,54 +734,54 @@ This also does some trivial optimizations to make the form prettier."
(if (symbolp exp) exp
(setq letf t) (list exp nil)))) res)
(setq lets (cdr lets)))
(list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
(cl-list* (if letf (if (eq (car form) 'let) 'cl-letf 'cl-letf*) (car form))
(nreverse res) (cl-macroexpand-body (cddr form) env)))))
((eq (car form) 'cond)
(cons (car form)
(mapcar (function (lambda (x) (cl-macroexpand-body x env)))
(cdr form))))
((eq (car form) 'condition-case)
(list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
(cl-list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
(mapcar (function
(lambda (x)
(cons (car x) (cl-macroexpand-body (cdr x) env))))
(cdddr form))))
(cl-cdddr form))))
((memq (car form) '(quote function))
(if (eq (car-safe (nth 1 form)) 'lambda)
(let ((body (cl-macroexpand-body (cddadr form) env)))
(let ((body (cl-macroexpand-body (cl-cddadr form) env)))
(if (and cl-closure-vars (eq (car form) 'function)
(cl-expr-contains-any body cl-closure-vars))
(let* ((new (mapcar 'gensym cl-closure-vars))
(sub (pairlis cl-closure-vars new)) (decls nil))
(let* ((new (mapcar 'cl-gensym cl-closure-vars))
(sub (cl-pairlis cl-closure-vars new)) (decls nil))
(while (or (stringp (car body))
(eq (car-safe (car body)) 'interactive))
(push (list 'quote (pop body)) decls))
(put (car (last cl-closure-vars)) 'used t)
`(list 'lambda '(&rest --cl-rest--)
,@(sublis sub (nreverse decls))
,@(cl-sublis sub (nreverse decls))
(list 'apply
(list 'quote
#'(lambda ,(append new (cadadr form))
,@(sublis sub body)))
#'(lambda ,(append new (cl-cadadr form))
,@(cl-sublis sub body)))
,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
cl-closure-vars)
'((quote --cl-rest--))))))
(list (car form) (list* 'lambda (cadadr form) body))))
(list (car form) (cl-list* 'lambda (cl-cadadr form) body))))
(let ((found (assq (cadr form) env)))
(if (and found (ignore-errors
(eq (cadr (caddr found)) 'cl-labels-args)))
(cl-macroexpand-all (cadr (caddr (cadddr found))) env)
(eq (cadr (cl-caddr found)) 'cl-labels-args)))
(cl-macroexpand-all (cadr (cl-caddr (cl-cadddr found))) env)
form))))
((memq (car form) '(defun defmacro))
(list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
(cl-list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
((and (eq (car form) 'progn) (not (cddr form)))
(cl-macroexpand-all (nth 1 form) env))
((eq (car form) 'setq)
(let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
(while (and p (symbolp (car p))) (setq p (cddr p)))
(if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
(if p (cl-macroexpand-all (cons 'cl-setf args)) (cons 'setq args))))
((consp (car form))
(cl-macroexpand-all (list* 'funcall
(cl-macroexpand-all (cl-list* 'funcall
(list 'function (car form))
(cdr form))
env))
@ -800,7 +796,7 @@ This also does some trivial optimizations to make the form prettier."
(let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
(byte-compile-macro-environment nil))
(setq form (cl-macroexpand-all form
(and (not full) '((block) (eval-when)))))
(and (not full) '((cl-block) (cl-eval-when)))))
(message "Formatting...")
(prog1 (cl-prettyprint form)
(message ""))))

693
lisp/emacs-lisp/cl-lib.el Normal file
View File

@ -0,0 +1,693 @@
;;; cl-lib.el --- Common Lisp extensions for Emacs
;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions
;; 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; These are extensions to Emacs Lisp that provide a degree of
;; Common Lisp compatibility, beyond what is already built-in
;; in Emacs Lisp.
;;
;; This package was written by Dave Gillespie; it is a complete
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
;;
;; Bug reports, comments, and suggestions are welcome!
;; This file contains the portions of the Common Lisp extensions
;; package which should always be present.
;;; Future notes:
;; Once Emacs 19 becomes standard, many things in this package which are
;; messy for reasons of compatibility can be greatly simplified. For now,
;; I prefer to maintain one unified version.
;;; Change Log:
;; Version 2.02 (30 Jul 93):
;; * Added "cl-compat.el" file, extra compatibility with old package.
;; * Added `lexical-let' and `lexical-let*'.
;; * Added `define-modify-macro', `callf', and `callf2'.
;; * Added `ignore-errors'.
;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero.
;; * Merged `*gentemp-counter*' into `*gensym-counter*'.
;; * Extended `subseq' to allow negative START and END like `substring'.
;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses.
;; * Added `concat', `vconcat' loop clauses.
;; * Cleaned up a number of compiler warnings.
;; Version 2.01 (7 Jul 93):
;; * Added support for FSF version of Emacs 19.
;; * Added `add-hook' for Emacs 18 users.
;; * Added `defsubst*' and `symbol-macrolet'.
;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'.
;; * Added `map', `concatenate', `reduce', `merge'.
;; * Added `revappend', `nreconc', `tailp', `tree-equal'.
;; * Added `assert', `check-type', `typecase', `typep', and `deftype'.
;; * Added destructuring and `&environment' support to `defmacro*'.
;; * Added destructuring to `loop', and added the following clauses:
;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'.
;; * Renamed `delete' to `delete*' and `remove' to `remove*'.
;; * Completed support for all keywords in `remove*', `substitute', etc.
;; * Added `most-positive-float' and company.
;; * Fixed hash tables to work with latest Lucid Emacs.
;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'.
;; * Syntax for `warn' declarations has changed.
;; * Improved implementation of `random*'.
;; * Moved most sequence functions to a new file, cl-seq.el.
;; * Moved `eval-when' into cl-macs.el.
;; * Moved `pushnew' and `adjoin' to cl.el for most common cases.
;; * Moved `provide' forms down to ends of files.
;; * Changed expansion of `pop' to something that compiles to better code.
;; * Changed so that no patch is required for Emacs 19 byte compiler.
;; * Made more things dependent on `optimize' declarations.
;; * Added a partial implementation of struct print functions.
;; * Miscellaneous minor changes.
;; Version 2.00:
;; * First public release of this package.
;;; Code:
(defvar cl-optimize-speed 1)
(defvar cl-optimize-safety 1)
;;;###autoload
(defvar cl-custom-print-functions nil
"This is a list of functions that format user objects for printing.
Each function is called in turn with three arguments: the object, the
stream, and the print level (currently ignored). If it is able to
print the object it returns true; otherwise it returns nil and the
printer proceeds to the next function on the list.
This variable is not used at present, but it is defined in hopes that
a future Emacs interpreter will be able to use it.")
(defun cl-unload-function ()
"Stop unloading of the Common Lisp extensions."
(message "Cannot unload the feature `cl'")
;; stop standard unloading!
t)
;;; Generalized variables.
;; These macros are defined here so that they
;; can safely be used in .emacs files.
(defmacro cl-incf (place &optional x)
"Increment PLACE by X (1 by default).
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
The return value is the incremented value of PLACE."
(declare (debug (place &optional form)))
(if (symbolp place)
(list 'setq place (if x (list '+ place x) (list '1+ place)))
(list 'cl-callf '+ place (or x 1))))
(defmacro cl-decf (place &optional x)
"Decrement PLACE by X (1 by default).
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
The return value is the decremented value of PLACE."
(declare (debug cl-incf))
(if (symbolp place)
(list 'setq place (if x (list '- place x) (list '1- place)))
(list 'cl-callf '- place (or x 1))))
;; Autoloaded, but we haven't loaded cl-loaddefs yet.
(declare-function cl-do-pop "cl-macs" (place))
(defmacro cl-pop (place)
"Remove and return the head of the list stored in PLACE.
Analogous to (prog1 (car PLACE) (cl-setf PLACE (cdr PLACE))), though more
careful about evaluating each argument only once and in the right order.
PLACE may be a symbol, or any generalized variable allowed by `cl-setf'."
(declare (debug (place)))
(if (symbolp place)
(list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))
(cl-do-pop place)))
(defmacro cl-push (x place)
"Insert X at the head of the list stored in PLACE.
Analogous to (cl-setf PLACE (cons X PLACE)), though more careful about
evaluating each argument only once and in the right order. PLACE may
be a symbol, or any generalized variable allowed by `cl-setf'."
(declare (debug (form place)))
(if (symbolp place) (list 'setq place (list 'cons x place))
(list 'cl-callf2 'cons x place)))
(defmacro cl-pushnew (x place &rest keys)
"(cl-pushnew X PLACE): insert X at the head of the list if not already there.
Like (cl-push X PLACE), except that the list is unmodified if X is `eql' to
an element already on the list.
\nKeywords supported: :test :test-not :key
\n(fn X PLACE [KEYWORD VALUE]...)"
(declare (debug
(form place &rest
&or [[&or ":test" ":test-not" ":key"] function-form]
[keywordp form])))
(if (symbolp place)
(if (null keys)
`(let ((x ,x))
(if (memql x ,place)
;; This symbol may later on expand to actual code which then
;; trigger warnings like "value unused" since cl-pushnew's return
;; value is rarely used. It should not matter that other
;; warnings may be silenced, since `place' is used earlier and
;; should have triggered them already.
(with-no-warnings ,place)
(setq ,place (cons x ,place))))
(list 'setq place (cl-list* 'cl-adjoin x place keys)))
(cl-list* 'cl-callf2 'cl-adjoin x place keys)))
(defun cl-set-elt (seq n val)
(if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
(defsubst cl-set-nthcdr (n list x)
(if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
(defun cl-set-buffer-substring (start end val)
(save-excursion (delete-region start end)
(goto-char start)
(insert val)
val))
(defun cl-set-substring (str start end val)
(if end (if (< end 0) (cl-incf end (length str)))
(setq end (length str)))
(if (< start 0) (cl-incf start (length str)))
(concat (and (> start 0) (substring str 0 start))
val
(and (< end (length str)) (substring str end))))
;;; Control structures.
;; These macros are so simple and so often-used that it's better to have
;; them all the time than to load them from cl-macs.el.
(defun cl-map-extents (&rest cl-args)
(apply 'cl-map-overlays cl-args))
;;; Blocks and exits.
(defalias 'cl-block-wrapper 'identity)
(defalias 'cl-block-throw 'throw)
;;; Multiple values.
;; True multiple values are not supported, or even
;; simulated. Instead, cl-multiple-value-bind and friends simply expect
;; the target form to return the values as a list.
(defalias 'cl-values #'list
"Return multiple values, Common Lisp style.
The arguments of `cl-values' are the values
that the containing function should return.
\(fn &rest VALUES)")
(defalias 'cl-values-list #'identity
"Return multiple values, Common Lisp style, taken from a list.
LIST specifies the list of values
that the containing function should return.
\(fn LIST)")
(defsubst cl-multiple-value-list (expression)
"Return a list of the multiple values produced by EXPRESSION.
This handles multiple values in Common Lisp style, but it does not
work right when EXPRESSION calls an ordinary Emacs Lisp function
that returns just one value."
expression)
(defsubst cl-multiple-value-apply (function expression)
"Evaluate EXPRESSION to get multiple values and apply FUNCTION to them.
This handles multiple values in Common Lisp style, but it does not work
right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
one value."
(apply function expression))
(defalias 'cl-multiple-value-call 'apply
"Apply FUNCTION to ARGUMENTS, taking multiple values into account.
This implementation only handles the case where there is only one argument.")
(defsubst cl-nth-value (n expression)
"Evaluate EXPRESSION to get multiple values and return the Nth one.
This handles multiple values in Common Lisp style, but it does not work
right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
one value."
(nth n expression))
;;; Macros.
(defvar cl-macro-environment)
(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand)
(defalias 'macroexpand 'cl-macroexpand)))
(defun cl-macroexpand (cl-macro &optional cl-env)
"Return result of expanding macros at top level of FORM.
If FORM is not a macro call, it is returned unchanged.
Otherwise, the macro is expanded and the expansion is considered
in place of FORM. When a non-macro-call results, it is returned.
The second optional arg ENVIRONMENT specifies an environment of macro
definitions to shadow the loaded ones for use in file byte-compilation.
\n(fn FORM &optional ENVIRONMENT)"
(let ((cl-macro-environment cl-env))
(while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
(and (symbolp cl-macro)
(cdr (assq (symbol-name cl-macro) cl-env))))
(setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))
cl-macro))
;;; Declarations.
(defvar cl-compiling-file nil)
(defun cl-compiling-file ()
(or cl-compiling-file
(and (boundp 'byte-compile--outbuffer)
(bufferp (symbol-value 'byte-compile--outbuffer))
(equal (buffer-name (symbol-value 'byte-compile--outbuffer))
" *Compiler Output*"))))
(defvar cl-proclaims-deferred nil)
(defun cl-proclaim (spec)
(if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
(push spec cl-proclaims-deferred))
nil)
(defmacro cl-declaim (&rest specs)
(let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x))))
specs)))
(if (cl-compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
(cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when
;;; Symbols.
(defun cl-random-time ()
(let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
(while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
v))
(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100))
;;; Numbers.
(defun cl-floatp-safe (object)
"Return t if OBJECT is a floating point number.
On Emacs versions that lack floating-point support, this function
always returns nil."
(and (numberp object) (not (integerp object))))
(defun cl-plusp (number)
"Return t if NUMBER is positive."
(> number 0))
(defun cl-minusp (number)
"Return t if NUMBER is negative."
(< number 0))
(defun cl-oddp (integer)
"Return t if INTEGER is odd."
(eq (logand integer 1) 1))
(defun cl-evenp (integer)
"Return t if INTEGER is even."
(eq (logand integer 1) 0))
(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time)))
(defconst cl-most-positive-float nil
"The largest value that a Lisp float can hold.
If your system supports infinities, this is the largest finite value.
For IEEE machines, this is approximately 1.79e+308.
Call `cl-float-limits' to set this.")
(defconst cl-most-negative-float nil
"The largest negative value that a Lisp float can hold.
This is simply -`cl-most-positive-float'.
Call `cl-float-limits' to set this.")
(defconst cl-least-positive-float nil
"The smallest value greater than zero that a Lisp float can hold.
For IEEE machines, it is about 4.94e-324 if denormals are supported,
or 2.22e-308 if they are not.
Call `cl-float-limits' to set this.")
(defconst cl-least-negative-float nil
"The smallest value less than zero that a Lisp float can hold.
This is simply -`cl-least-positive-float'.
Call `cl-float-limits' to set this.")
(defconst cl-least-positive-normalized-float nil
"The smallest normalized Lisp float greater than zero.
This is the smallest value for which IEEE denormalization does not lose
precision. For IEEE machines, this value is about 2.22e-308.
For machines that do not support the concept of denormalization
and gradual underflow, this constant equals `cl-least-positive-float'.
Call `cl-float-limits' to set this.")
(defconst cl-least-negative-normalized-float nil
"The smallest normalized Lisp float less than zero.
This is simply -`cl-least-positive-normalized-float'.
Call `cl-float-limits' to set this.")
(defconst cl-float-epsilon nil
"The smallest positive float that adds to 1.0 to give a distinct value.
Adding a number less than this to 1.0 returns 1.0 due to roundoff.
For IEEE machines, epsilon is about 2.22e-16.
Call `cl-float-limits' to set this.")
(defconst cl-float-negative-epsilon nil
"The smallest positive float that subtracts from 1.0 to give a distinct value.
For IEEE machines, it is about 1.11e-16.
Call `cl-float-limits' to set this.")
;;; Sequence functions.
(defalias 'cl-copy-seq 'copy-sequence)
(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs))
(defun cl-mapcar (cl-func cl-x &rest cl-rest)
"Apply FUNCTION to each element of SEQ, and make a list of the results.
If there are several SEQs, FUNCTION is called with that many arguments,
and mapping stops as soon as the shortest list runs out. With just one
SEQ, this is like `mapcar'. With several, it is like the Common Lisp
`mapcar' function extended to arbitrary sequence types.
\n(fn FUNCTION SEQ...)"
(if cl-rest
(if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
(cl-mapcar-many cl-func (cons cl-x cl-rest))
(let ((cl-res nil) (cl-y (car cl-rest)))
(while (and cl-x cl-y)
(push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
(nreverse cl-res)))
(mapcar cl-func cl-x)))
(defalias 'cl-svref 'aref)
;;; List functions.
(defalias 'cl-first 'car)
(defalias 'cl-second 'cadr)
(defalias 'cl-rest 'cdr)
(defalias 'cl-endp 'null)
(defun cl-third (x)
"Return the cl-third element of the list X."
(car (cdr (cdr x))))
(defun cl-fourth (x)
"Return the cl-fourth element of the list X."
(nth 3 x))
(defun cl-fifth (x)
"Return the cl-fifth element of the list X."
(nth 4 x))
(defun cl-sixth (x)
"Return the cl-sixth element of the list X."
(nth 5 x))
(defun cl-seventh (x)
"Return the cl-seventh element of the list X."
(nth 6 x))
(defun cl-eighth (x)
"Return the cl-eighth element of the list X."
(nth 7 x))
(defun cl-ninth (x)
"Return the cl-ninth element of the list X."
(nth 8 x))
(defun cl-tenth (x)
"Return the cl-tenth element of the list X."
(nth 9 x))
(defun cl-caaar (x)
"Return the `car' of the `car' of the `car' of X."
(car (car (car x))))
(defun cl-caadr (x)
"Return the `car' of the `car' of the `cdr' of X."
(car (car (cdr x))))
(defun cl-cadar (x)
"Return the `car' of the `cdr' of the `car' of X."
(car (cdr (car x))))
(defun cl-caddr (x)
"Return the `car' of the `cdr' of the `cdr' of X."
(car (cdr (cdr x))))
(defun cl-cdaar (x)
"Return the `cdr' of the `car' of the `car' of X."
(cdr (car (car x))))
(defun cl-cdadr (x)
"Return the `cdr' of the `car' of the `cdr' of X."
(cdr (car (cdr x))))
(defun cl-cddar (x)
"Return the `cdr' of the `cdr' of the `car' of X."
(cdr (cdr (car x))))
(defun cl-cdddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of X."
(cdr (cdr (cdr x))))
(defun cl-caaaar (x)
"Return the `car' of the `car' of the `car' of the `car' of X."
(car (car (car (car x)))))
(defun cl-caaadr (x)
"Return the `car' of the `car' of the `car' of the `cdr' of X."
(car (car (car (cdr x)))))
(defun cl-caadar (x)
"Return the `car' of the `car' of the `cdr' of the `car' of X."
(car (car (cdr (car x)))))
(defun cl-caaddr (x)
"Return the `car' of the `car' of the `cdr' of the `cdr' of X."
(car (car (cdr (cdr x)))))
(defun cl-cadaar (x)
"Return the `car' of the `cdr' of the `car' of the `car' of X."
(car (cdr (car (car x)))))
(defun cl-cadadr (x)
"Return the `car' of the `cdr' of the `car' of the `cdr' of X."
(car (cdr (car (cdr x)))))
(defun cl-caddar (x)
"Return the `car' of the `cdr' of the `cdr' of the `car' of X."
(car (cdr (cdr (car x)))))
(defun cl-cadddr (x)
"Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
(car (cdr (cdr (cdr x)))))
(defun cl-cdaaar (x)
"Return the `cdr' of the `car' of the `car' of the `car' of X."
(cdr (car (car (car x)))))
(defun cl-cdaadr (x)
"Return the `cdr' of the `car' of the `car' of the `cdr' of X."
(cdr (car (car (cdr x)))))
(defun cl-cdadar (x)
"Return the `cdr' of the `car' of the `cdr' of the `car' of X."
(cdr (car (cdr (car x)))))
(defun cl-cdaddr (x)
"Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
(cdr (car (cdr (cdr x)))))
(defun cl-cddaar (x)
"Return the `cdr' of the `cdr' of the `car' of the `car' of X."
(cdr (cdr (car (car x)))))
(defun cl-cddadr (x)
"Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
(cdr (cdr (car (cdr x)))))
(defun cl-cdddar (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
(cdr (cdr (cdr (car x)))))
(defun cl-cddddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
(cdr (cdr (cdr (cdr x)))))
;;(defun last* (x &optional n)
;; "Returns the last link in the list LIST.
;;With optional argument N, returns Nth-to-last link (default 1)."
;; (if n
;; (let ((m 0) (p x))
;; (while (consp p) (cl-incf m) (pop p))
;; (if (<= n 0) p
;; (if (< n m) (nthcdr (- m n) x) x)))
;; (while (consp (cdr x)) (pop x))
;; x))
(defun cl-list* (arg &rest rest) ; See compiler macro in cl-macs.el
"Return a new list with specified ARGs as elements, consed to last ARG.
Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
`(cons A (cons B (cons C D)))'.
\n(fn ARG...)"
(cond ((not rest) arg)
((not (cdr rest)) (cons arg (car rest)))
(t (let* ((n (length rest))
(copy (copy-sequence rest))
(last (nthcdr (- n 2) copy)))
(setcdr last (car (cdr last)))
(cons arg copy)))))
(defun cl-ldiff (list sublist)
"Return a copy of LIST with the tail SUBLIST removed."
(let ((res nil))
(while (and (consp list) (not (eq list sublist)))
(push (pop list) res))
(nreverse res)))
(defun cl-copy-list (list)
"Return a copy of LIST, which may be a dotted list.
The elements of LIST are not copied, just the list structure itself."
(if (consp list)
(let ((res nil))
(while (consp list) (push (pop list) res))
(prog1 (nreverse res) (setcdr res list)))
(car list)))
(defun cl-maclisp-member (item list)
(while (and list (not (equal item (car list)))) (setq list (cdr list)))
list)
(defalias 'cl-member 'memq) ; for compatibility with old CL package
;; Autoloaded, but we have not loaded cl-loaddefs yet.
(declare-function cl-floor "cl-extra" (x &optional y))
(declare-function cl-ceiling "cl-extra" (x &optional y))
(declare-function cl-truncate "cl-extra" (x &optional y))
(declare-function cl-round "cl-extra" (x &optional y))
(declare-function cl-mod "cl-extra" (x y))
(defun cl-adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs
"Return ITEM consed onto the front of LIST only if it's not already there.
Otherwise, return LIST unmodified.
\nKeywords supported: :test :test-not :key
\n(fn ITEM LIST [KEYWORD VALUE]...)"
(cond ((or (equal cl-keys '(:test eq))
(and (null cl-keys) (not (numberp cl-item))))
(if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
((or (equal cl-keys '(:test equal)) (null cl-keys))
(if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
(t (apply 'cl--adjoin cl-item cl-list cl-keys))))
(defun cl-subst (cl-new cl-old cl-tree &rest cl-keys)
"Substitute NEW for OLD everywhere in TREE (non-destructively).
Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
\nKeywords supported: :test :test-not :key
\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
(if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
(apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
(cl-do-subst cl-new cl-old cl-tree)))
(defun cl-do-subst (cl-new cl-old cl-tree)
(cond ((eq cl-tree cl-old) cl-new)
((consp cl-tree)
(let ((a (cl-do-subst cl-new cl-old (car cl-tree)))
(d (cl-do-subst cl-new cl-old (cdr cl-tree))))
(if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
cl-tree (cons a d))))
(t cl-tree)))
(defun cl-acons (key value alist)
"Add KEY and VALUE to ALIST.
Return a new list with (cons KEY VALUE) as car and ALIST as cdr."
(cons (cons key value) alist))
(defun cl-pairlis (keys values &optional alist)
"Make an alist from KEYS and VALUES.
Return a new alist composed by associating KEYS to corresponding VALUES;
the process stops as soon as KEYS or VALUES run out.
If ALIST is non-nil, the new pairs are prepended to it."
(nconc (cl-mapcar 'cons keys values) alist))
;;; Miscellaneous.
;;;###autoload
(progn
;; Autoload, so autoload.el and font-lock can use it even when CL
;; is not loaded.
(put 'cl-defun 'doc-string-elt 3)
(put 'cl-defmacro 'doc-string-elt 3)
(put 'cl-defsubst 'doc-string-elt 3)
(put 'cl-defstruct 'doc-string-elt 2))
(load "cl-loaddefs" nil 'quiet)
;; This goes here so that cl-macs can find it if it loads right now.
(provide 'cl-lib)
;; Things to do after byte-compiler is loaded.
(defvar cl-hacked-flag nil)
(defun cl-hack-byte-compiler ()
(and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)
(progn
(setq cl-hacked-flag t) ; Do it first, to prevent recursion.
(load "cl-macs" nil t)
(run-hooks 'cl-hack-bytecomp-hook))))
;; Try it now in case the compiler has already been loaded.
(cl-hack-byte-compiler)
;; Also make a hook in case compiler is loaded after this file.
(add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler)
;; The following ensures that packages which expect the old-style cl.el
;; will be happy with this one.
(provide 'cl-lib)
(run-hooks 'cl-load-hook)
;; Local variables:
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; End:
;;; cl-lib.el ends here

1355
lisp/emacs-lisp/cl-macs.el
View File

File diff suppressed because it is too large Load Diff

212
lisp/emacs-lisp/cl-seq.el
View File

@ -41,7 +41,7 @@
;;; Code:
(require 'cl)
(require 'cl-lib)
;;; Keyword parsing. This is special-cased here so that we can compile
;;; this file independent from cl-macs.
@ -118,13 +118,13 @@
;;;###autoload
(defun reduce (cl-func cl-seq &rest cl-keys)
(defun cl-reduce (cl-func cl-seq &rest cl-keys)
"Reduce two-argument FUNCTION across SEQ.
\nKeywords supported: :start :end :from-end :initial-value :key
\n(fn FUNCTION SEQ [KEYWORD VALUE]...)"
(cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
(or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
(setq cl-seq (subseq cl-seq cl-start cl-end))
(setq cl-seq (cl-subseq cl-seq cl-start cl-end))
(if cl-from-end (setq cl-seq (nreverse cl-seq)))
(let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value)
(cl-seq (cl-check-key (pop cl-seq)))
@ -139,7 +139,7 @@
cl-accum)))
;;;###autoload
(defun fill (seq item &rest cl-keys)
(defun cl-fill (seq item &rest cl-keys)
"Fill the elements of SEQ with ITEM.
\nKeywords supported: :start :end
\n(fn SEQ ITEM [KEYWORD VALUE]...)"
@ -159,7 +159,7 @@
seq))
;;;###autoload
(defun replace (cl-seq1 cl-seq2 &rest cl-keys)
(defun cl-replace (cl-seq1 cl-seq2 &rest cl-keys)
"Replace the elements of SEQ1 with the elements of SEQ2.
SEQ1 is destructively modified, then returned.
\nKeywords supported: :start1 :end1 :start2 :end2
@ -202,7 +202,7 @@ SEQ1 is destructively modified, then returned.
cl-seq1))
;;;###autoload
(defun remove* (cl-item cl-seq &rest cl-keys)
(defun cl-remove (cl-item cl-seq &rest cl-keys)
"Remove all occurrences of ITEM in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
@ -216,7 +216,7 @@ to avoid corrupting the original SEQ.
(let ((cl-i (cl--position cl-item cl-seq cl-start cl-end
cl-from-end)))
(if cl-i
(let ((cl-res (apply 'delete* cl-item (append cl-seq nil)
(let ((cl-res (apply 'cl-delete cl-item (append cl-seq nil)
(append (if cl-from-end
(list :end (1+ cl-i))
(list :start cl-i))
@ -237,10 +237,10 @@ to avoid corrupting the original SEQ.
(not (cl-check-test cl-item (car cl-p))))
(setq cl-p (cdr cl-p) cl-end (1- cl-end)))
(if (and cl-p (> cl-end 0))
(nconc (ldiff cl-seq cl-p)
(nconc (cl-ldiff cl-seq cl-p)
(if (= cl-count 1) (cdr cl-p)
(and (cdr cl-p)
(apply 'delete* cl-item
(apply 'cl-delete cl-item
(copy-sequence (cdr cl-p))
:start 0 :end (1- cl-end)
:count (1- cl-count) cl-keys))))
@ -248,25 +248,25 @@ to avoid corrupting the original SEQ.
cl-seq)))))
;;;###autoload
(defun remove-if (cl-pred cl-list &rest cl-keys)
(defun cl-remove-if (cl-pred cl-list &rest cl-keys)
"Remove all items satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
\nKeywords supported: :key :count :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'remove* nil cl-list :if cl-pred cl-keys))
(apply 'cl-remove nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun remove-if-not (cl-pred cl-list &rest cl-keys)
(defun cl-remove-if-not (cl-pred cl-list &rest cl-keys)
"Remove all items not satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
\nKeywords supported: :key :count :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'remove* nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-remove nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun delete* (cl-item cl-seq &rest cl-keys)
(defun cl-delete (cl-item cl-seq &rest cl-keys)
"Remove all occurrences of ITEM in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :test :test-not :key :count :start :end :from-end
@ -307,33 +307,33 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
(setq cl-p (cdr cl-p)))
(setq cl-end (1- cl-end)))))
cl-seq)
(apply 'remove* cl-item cl-seq cl-keys)))))
(apply 'cl-remove cl-item cl-seq cl-keys)))))
;;;###autoload
(defun delete-if (cl-pred cl-list &rest cl-keys)
(defun cl-delete-if (cl-pred cl-list &rest cl-keys)
"Remove all items satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :key :count :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'delete* nil cl-list :if cl-pred cl-keys))
(apply 'cl-delete nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun delete-if-not (cl-pred cl-list &rest cl-keys)
(defun cl-delete-if-not (cl-pred cl-list &rest cl-keys)
"Remove all items not satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :key :count :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'delete* nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-delete nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun remove-duplicates (cl-seq &rest cl-keys)
(defun cl-remove-duplicates (cl-seq &rest cl-keys)
"Return a copy of SEQ with all duplicate elements removed.
\nKeywords supported: :test :test-not :key :start :end :from-end
\n(fn SEQ [KEYWORD VALUE]...)"
(cl--delete-duplicates cl-seq cl-keys t))
;;;###autoload
(defun delete-duplicates (cl-seq &rest cl-keys)
(defun cl-delete-duplicates (cl-seq &rest cl-keys)
"Remove all duplicate elements from SEQ (destructively).
\nKeywords supported: :test :test-not :key :start :end :from-end
\n(fn SEQ [KEYWORD VALUE]...)"
@ -380,7 +380,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
(if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))))
;;;###autoload
(defun substitute (cl-new cl-old cl-seq &rest cl-keys)
(defun cl-substitute (cl-new cl-old cl-seq &rest cl-keys)
"Substitute NEW for OLD in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
@ -398,29 +398,29 @@ to avoid corrupting the original SEQ.
(or cl-from-end
(progn (cl-set-elt cl-seq cl-i cl-new)
(setq cl-i (1+ cl-i) cl-count (1- cl-count))))
(apply 'nsubstitute cl-new cl-old cl-seq :count cl-count
(apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count
:start cl-i cl-keys))))))
;;;###autoload
(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
(defun cl-substitute-if (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
\nKeywords supported: :key :count :start :end :from-end
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'substitute cl-new nil cl-list :if cl-pred cl-keys))
(apply 'cl-substitute cl-new nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
(defun cl-substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items not satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
to avoid corrupting the original SEQ.
\nKeywords supported: :key :count :start :end :from-end
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-substitute cl-new nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
(defun cl-nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
"Substitute NEW for OLD in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :test :test-not :key :count :start :end :from-end
@ -454,48 +454,48 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
cl-seq))
;;;###autoload
(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
(defun cl-nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :key :count :start :end :from-end
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
(apply 'cl-nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
(defun cl-nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items not satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
\nKeywords supported: :key :count :start :end :from-end
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun find (cl-item cl-seq &rest cl-keys)
(defun cl-find (cl-item cl-seq &rest cl-keys)
"Find the first occurrence of ITEM in SEQ.
Return the matching ITEM, or nil if not found.
\nKeywords supported: :test :test-not :key :start :end :from-end
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
(let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
(let ((cl-pos (apply 'cl-position cl-item cl-seq cl-keys)))
(and cl-pos (elt cl-seq cl-pos))))
;;;###autoload
(defun find-if (cl-pred cl-list &rest cl-keys)
(defun cl-find-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in SEQ.
Return the matching item, or nil if not found.
\nKeywords supported: :key :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'find nil cl-list :if cl-pred cl-keys))
(apply 'cl-find nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun find-if-not (cl-pred cl-list &rest cl-keys)
(defun cl-find-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in SEQ.
Return the matching item, or nil if not found.
\nKeywords supported: :key :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'find nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-find nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun position (cl-item cl-seq &rest cl-keys)
(defun cl-position (cl-item cl-seq &rest cl-keys)
"Find the first occurrence of ITEM in SEQ.
Return the index of the matching item, or nil if not found.
\nKeywords supported: :test :test-not :key :start :end :from-end
@ -526,23 +526,23 @@ Return the index of the matching item, or nil if not found.
(and (< cl-start cl-end) cl-start))))
;;;###autoload
(defun position-if (cl-pred cl-list &rest cl-keys)
(defun cl-position-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in SEQ.
Return the index of the matching item, or nil if not found.
\nKeywords supported: :key :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'position nil cl-list :if cl-pred cl-keys))
(apply 'cl-position nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun position-if-not (cl-pred cl-list &rest cl-keys)
(defun cl-position-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in SEQ.
Return the index of the matching item, or nil if not found.
\nKeywords supported: :key :start :end :from-end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'position nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-position nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun count (cl-item cl-seq &rest cl-keys)
(defun cl-count (cl-item cl-seq &rest cl-keys)
"Count the number of occurrences of ITEM in SEQ.
\nKeywords supported: :test :test-not :key :start :end
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
@ -557,21 +557,21 @@ Return the index of the matching item, or nil if not found.
cl-count)))
;;;###autoload
(defun count-if (cl-pred cl-list &rest cl-keys)
(defun cl-count-if (cl-pred cl-list &rest cl-keys)
"Count the number of items satisfying PREDICATE in SEQ.
\nKeywords supported: :key :start :end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'count nil cl-list :if cl-pred cl-keys))
(apply 'cl-count nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun count-if-not (cl-pred cl-list &rest cl-keys)
(defun cl-count-if-not (cl-pred cl-list &rest cl-keys)
"Count the number of items not satisfying PREDICATE in SEQ.
\nKeywords supported: :key :start :end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'count nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-count nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
(defun cl-mismatch (cl-seq1 cl-seq2 &rest cl-keys)
"Compare SEQ1 with SEQ2, return index of first mismatching element.
Return nil if the sequences match. If one sequence is a prefix of the
other, the return value indicates the end of the shorter sequence.
@ -602,7 +602,7 @@ other, the return value indicates the end of the shorter sequence.
cl-start1)))))
;;;###autoload
(defun search (cl-seq1 cl-seq2 &rest cl-keys)
(defun cl-search (cl-seq1 cl-seq2 &rest cl-keys)
"Search for SEQ1 as a subsequence of SEQ2.
Return the index of the leftmost element of the first match found;
return nil if there are no matches.
@ -621,7 +621,7 @@ return nil if there are no matches.
(while (and (< cl-start2 cl-end2)
(setq cl-pos (cl--position cl-first cl-seq2
cl-start2 cl-end2 cl-from-end))
(apply 'mismatch cl-seq1 cl-seq2
(apply 'cl-mismatch cl-seq1 cl-seq2
:start1 (1+ cl-start1) :end1 cl-end1
:start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
:from-end nil cl-keys))
@ -629,13 +629,13 @@ return nil if there are no matches.
(and (< cl-start2 cl-end2) cl-pos)))))
;;;###autoload
(defun sort* (cl-seq cl-pred &rest cl-keys)
(defun cl-sort (cl-seq cl-pred &rest cl-keys)
"Sort the argument SEQ according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
\nKeywords supported: :key
\n(fn SEQ PREDICATE [KEYWORD VALUE]...)"
(if (nlistp cl-seq)
(replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys))
(cl-replace cl-seq (apply 'cl-sort (append cl-seq nil) cl-pred cl-keys))
(cl-parsing-keywords (:key) ()
(if (memq cl-key '(nil identity))
(sort cl-seq cl-pred)
@ -644,15 +644,15 @@ This is a destructive function; it reuses the storage of SEQ if possible.
(funcall cl-key cl-y)))))))))
;;;###autoload
(defun stable-sort (cl-seq cl-pred &rest cl-keys)
(defun cl-stable-sort (cl-seq cl-pred &rest cl-keys)
"Sort the argument SEQ stably according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
\nKeywords supported: :key
\n(fn SEQ PREDICATE [KEYWORD VALUE]...)"
(apply 'sort* cl-seq cl-pred cl-keys))
(apply 'cl-sort cl-seq cl-pred cl-keys))
;;;###autoload
(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
(defun cl-merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
"Destructively merge the two sequences to produce a new sequence.
TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument
sequences, and PREDICATE is a `less-than' predicate on the elements.
@ -667,11 +667,11 @@ sequences, and PREDICATE is a `less-than' predicate on the elements.
(cl-check-key (car cl-seq1)))
(push (pop cl-seq2) cl-res)
(push (pop cl-seq1) cl-res)))
(coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
(cl-coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
;;; See compiler macro in cl-macs.el
;;;###autoload
(defun member* (cl-item cl-list &rest cl-keys)
(defun cl-member (cl-item cl-list &rest cl-keys)
"Find the first occurrence of ITEM in LIST.
Return the sublist of LIST whose car is ITEM.
\nKeywords supported: :test :test-not :key
@ -686,31 +686,31 @@ Return the sublist of LIST whose car is ITEM.
(memq cl-item cl-list))))
;;;###autoload
(defun member-if (cl-pred cl-list &rest cl-keys)
(defun cl-member-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'member* nil cl-list :if cl-pred cl-keys))
(apply 'cl-member nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun member-if-not (cl-pred cl-list &rest cl-keys)
(defun cl-member-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'member* nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-member nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun cl--adjoin (cl-item cl-list &rest cl-keys)
(if (cl-parsing-keywords (:key) t
(apply 'member* (cl-check-key cl-item) cl-list cl-keys))
(apply 'cl-member (cl-check-key cl-item) cl-list cl-keys))
cl-list
(cons cl-item cl-list)))
;;; See compiler macro in cl-macs.el
;;;###autoload
(defun assoc* (cl-item cl-alist &rest cl-keys)
(defun cl-assoc (cl-item cl-alist &rest cl-keys)
"Find the first item whose car matches ITEM in LIST.
\nKeywords supported: :test :test-not :key
\n(fn ITEM LIST [KEYWORD VALUE]...)"
@ -726,21 +726,21 @@ Return the sublist of LIST whose car matches.
(assq cl-item cl-alist))))
;;;###autoload
(defun assoc-if (cl-pred cl-list &rest cl-keys)
(defun cl-assoc-if (cl-pred cl-list &rest cl-keys)
"Find the first item whose car satisfies PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'assoc* nil cl-list :if cl-pred cl-keys))
(apply 'cl-assoc nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun assoc-if-not (cl-pred cl-list &rest cl-keys)
(defun cl-assoc-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item whose car does not satisfy PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'assoc* nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-assoc nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun rassoc* (cl-item cl-alist &rest cl-keys)
(defun cl-rassoc (cl-item cl-alist &rest cl-keys)
"Find the first item whose cdr matches ITEM in LIST.
\nKeywords supported: :test :test-not :key
\n(fn ITEM LIST [KEYWORD VALUE]...)"
@ -754,21 +754,21 @@ Return the sublist of LIST whose car matches.
(rassq cl-item cl-alist)))
;;;###autoload
(defun rassoc-if (cl-pred cl-list &rest cl-keys)
(defun cl-rassoc-if (cl-pred cl-list &rest cl-keys)
"Find the first item whose cdr satisfies PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'rassoc* nil cl-list :if cl-pred cl-keys))
(apply 'cl-rassoc nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
(defun cl-rassoc-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item whose cdr does not satisfy PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'rassoc* nil cl-list :if-not cl-pred cl-keys))
(apply 'cl-rassoc nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun union (cl-list1 cl-list2 &rest cl-keys)
(defun cl-union (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-union operation.
The resulting list contains all items that appear in either LIST1 or LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
@ -782,14 +782,14 @@ to avoid corrupting the original LIST1 and LIST2.
(setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
(while cl-list2
(if (or cl-keys (numberp (car cl-list2)))
(setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys))
(setq cl-list1 (apply 'cl-adjoin (car cl-list2) cl-list1 cl-keys))
(or (memq (car cl-list2) cl-list1)
(push (car cl-list2) cl-list1)))
(pop cl-list2))
cl-list1)))
;;;###autoload
(defun nunion (cl-list1 cl-list2 &rest cl-keys)
(defun cl-nunion (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-union operation.
The resulting list contains all items that appear in either LIST1 or LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
@ -797,10 +797,10 @@ whenever possible.
\nKeywords supported: :test :test-not :key
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
(t (apply 'union cl-list1 cl-list2 cl-keys))))
(t (apply 'cl-union cl-list1 cl-list2 cl-keys))))
;;;###autoload
(defun intersection (cl-list1 cl-list2 &rest cl-keys)
(defun cl-intersection (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-intersection operation.
The resulting list contains all items that appear in both LIST1 and LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
@ -815,7 +815,7 @@ to avoid corrupting the original LIST1 and LIST2.
(setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1))))
(while cl-list2
(if (if (or cl-keys (numberp (car cl-list2)))
(apply 'member* (cl-check-key (car cl-list2))
(apply 'cl-member (cl-check-key (car cl-list2))
cl-list1 cl-keys)
(memq (car cl-list2) cl-list1))
(push (car cl-list2) cl-res))
@ -823,17 +823,17 @@ to avoid corrupting the original LIST1 and LIST2.
cl-res)))))
;;;###autoload
(defun nintersection (cl-list1 cl-list2 &rest cl-keys)
(defun cl-nintersection (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-intersection operation.
The resulting list contains all items that appear in both LIST1 and LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
whenever possible.
\nKeywords supported: :test :test-not :key
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
(and cl-list1 cl-list2 (apply 'cl-intersection cl-list1 cl-list2 cl-keys)))
;;;###autoload
(defun set-difference (cl-list1 cl-list2 &rest cl-keys)
(defun cl-set-difference (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-difference operation.
The resulting list contains all items that appear in LIST1 but not LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
@ -845,7 +845,7 @@ to avoid corrupting the original LIST1 and LIST2.
(let ((cl-res nil))
(while cl-list1
(or (if (or cl-keys (numberp (car cl-list1)))
(apply 'member* (cl-check-key (car cl-list1))
(apply 'cl-member (cl-check-key (car cl-list1))
cl-list2 cl-keys)
(memq (car cl-list1) cl-list2))
(push (car cl-list1) cl-res))
@ -853,7 +853,7 @@ to avoid corrupting the original LIST1 and LIST2.
cl-res))))
;;;###autoload
(defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
(defun cl-nset-difference (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-difference operation.
The resulting list contains all items that appear in LIST1 but not LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
@ -861,10 +861,10 @@ whenever possible.
\nKeywords supported: :test :test-not :key
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(if (or (null cl-list1) (null cl-list2)) cl-list1
(apply 'set-difference cl-list1 cl-list2 cl-keys)))
(apply 'cl-set-difference cl-list1 cl-list2 cl-keys)))
;;;###autoload
(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
(defun cl-set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-exclusive-or operation.
The resulting list contains all items appearing in exactly one of LIST1, LIST2.
This is a non-destructive function; it makes a copy of the data if necessary
@ -873,11 +873,11 @@ to avoid corrupting the original LIST1 and LIST2.
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
((equal cl-list1 cl-list2) nil)
(t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
(apply 'set-difference cl-list2 cl-list1 cl-keys)))))
(t (append (apply 'cl-set-difference cl-list1 cl-list2 cl-keys)
(apply 'cl-set-difference cl-list2 cl-list1 cl-keys)))))
;;;###autoload
(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
(defun cl-nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-exclusive-or operation.
The resulting list contains all items appearing in exactly one of LIST1, LIST2.
This is a destructive function; it reuses the storage of LIST1 and LIST2
@ -886,11 +886,11 @@ whenever possible.
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
((equal cl-list1 cl-list2) nil)
(t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
(apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
(t (nconc (apply 'cl-nset-difference cl-list1 cl-list2 cl-keys)
(apply 'cl-nset-difference cl-list2 cl-list1 cl-keys)))))
;;;###autoload
(defun subsetp (cl-list1 cl-list2 &rest cl-keys)
(defun cl-subsetp (cl-list1 cl-list2 &rest cl-keys)
"Return true if LIST1 is a subset of LIST2.
I.e., if every element of LIST1 also appears in LIST2.
\nKeywords supported: :test :test-not :key
@ -899,54 +899,54 @@ I.e., if every element of LIST1 also appears in LIST2.
((equal cl-list1 cl-list2) t)
(t (cl-parsing-keywords (:key) (:test :test-not)
(while (and cl-list1
(apply 'member* (cl-check-key (car cl-list1))
(apply 'cl-member (cl-check-key (car cl-list1))
cl-list2 cl-keys))
(pop cl-list1))
(null cl-list1)))))
;;;###autoload
(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
(defun cl-subst-if (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced by NEW.
\nKeywords supported: :key
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
(apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
;;;###autoload
(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
(defun cl-subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
Return a copy of TREE with all non-matching elements replaced by NEW.
\nKeywords supported: :key
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
(apply 'cl-sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
;;;###autoload
(defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
(defun cl-nsubst (cl-new cl-old cl-tree &rest cl-keys)
"Substitute NEW for OLD everywhere in TREE (destructively).
Any element of TREE which is `eql' to OLD is changed to NEW (via a call
to `setcar').
\nKeywords supported: :test :test-not :key
\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
(apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
(apply 'cl-nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
;;;###autoload
(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
(defun cl-nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements matching PREDICATE in TREE (destructively).
Any element of TREE which matches is changed to NEW (via a call to `setcar').
\nKeywords supported: :key
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
(apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
;;;###autoload
(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
(defun cl-nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements not matching PREDICATE in TREE (destructively).
Any element of TREE which matches is changed to NEW (via a call to `setcar').
\nKeywords supported: :key
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
(apply 'cl-nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
;;;###autoload
(defun sublis (cl-alist cl-tree &rest cl-keys)
(defun cl-sublis (cl-alist cl-tree &rest cl-keys)
"Perform substitutions indicated by ALIST in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced.
\nKeywords supported: :test :test-not :key
@ -969,7 +969,7 @@ Return a copy of TREE with all matching elements replaced.
cl-tree))))
;;;###autoload
(defun nsublis (cl-alist cl-tree &rest cl-keys)
(defun cl-nsublis (cl-alist cl-tree &rest cl-keys)
"Perform substitutions indicated by ALIST in TREE (destructively).
Any matching element of TREE is changed via a call to `setcar'.
\nKeywords supported: :test :test-not :key
@ -994,7 +994,7 @@ Any matching element of TREE is changed via a call to `setcar'.
(setq cl-tree (cdr cl-tree))))))
;;;###autoload
(defun tree-equal (cl-x cl-y &rest cl-keys)
(defun cl-tree-equal (cl-x cl-y &rest cl-keys)
"Return t if trees TREE1 and TREE2 have `eql' leaves.
Atoms are compared by `eql'; cons cells are compared recursively.
\nKeywords supported: :test :test-not :key

984
lisp/emacs-lisp/cl.el
View File

@ -1,9 +1,8 @@
;;; cl.el --- Common Lisp extensions for Emacs
;;; cl.el --- Compatibility aliases for the old CL library.
;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
;; Copyright (C) 2012 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions
;; This file is part of GNU Emacs.
@ -23,680 +22,315 @@
;;; Commentary:
;; These are extensions to Emacs Lisp that provide a degree of
;; Common Lisp compatibility, beyond what is already built-in
;; in Emacs Lisp.
;;
;; This package was written by Dave Gillespie; it is a complete
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
;;
;; Bug reports, comments, and suggestions are welcome!
;; This file contains the portions of the Common Lisp extensions
;; package which should always be present.
;;; Future notes:
;; Once Emacs 19 becomes standard, many things in this package which are
;; messy for reasons of compatibility can be greatly simplified. For now,
;; I prefer to maintain one unified version.
;;; Change Log:
;; Version 2.02 (30 Jul 93):
;; * Added "cl-compat.el" file, extra compatibility with old package.
;; * Added `lexical-let' and `lexical-let*'.
;; * Added `define-modify-macro', `callf', and `callf2'.
;; * Added `ignore-errors'.
;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero.
;; * Merged `*gentemp-counter*' into `*gensym-counter*'.
;; * Extended `subseq' to allow negative START and END like `substring'.
;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses.
;; * Added `concat', `vconcat' loop clauses.
;; * Cleaned up a number of compiler warnings.
;; Version 2.01 (7 Jul 93):
;; * Added support for FSF version of Emacs 19.
;; * Added `add-hook' for Emacs 18 users.
;; * Added `defsubst*' and `symbol-macrolet'.
;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'.
;; * Added `map', `concatenate', `reduce', `merge'.
;; * Added `revappend', `nreconc', `tailp', `tree-equal'.
;; * Added `assert', `check-type', `typecase', `typep', and `deftype'.
;; * Added destructuring and `&environment' support to `defmacro*'.
;; * Added destructuring to `loop', and added the following clauses:
;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'.
;; * Renamed `delete' to `delete*' and `remove' to `remove*'.
;; * Completed support for all keywords in `remove*', `substitute', etc.
;; * Added `most-positive-float' and company.
;; * Fixed hash tables to work with latest Lucid Emacs.
;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'.
;; * Syntax for `warn' declarations has changed.
;; * Improved implementation of `random*'.
;; * Moved most sequence functions to a new file, cl-seq.el.
;; * Moved `eval-when' into cl-macs.el.
;; * Moved `pushnew' and `adjoin' to cl.el for most common cases.
;; * Moved `provide' forms down to ends of files.
;; * Changed expansion of `pop' to something that compiles to better code.
;; * Changed so that no patch is required for Emacs 19 byte compiler.
;; * Made more things dependent on `optimize' declarations.
;; * Added a partial implementation of struct print functions.
;; * Miscellaneous minor changes.
;; Version 2.00:
;; * First public release of this package.
;; This is a compatibility file which provides the old names provided by CL
;; before we cleaned up its namespace usage.
;;; Code:
(defvar cl-optimize-speed 1)
(defvar cl-optimize-safety 1)
;;;###autoload
(defvar custom-print-functions nil
"This is a list of functions that format user objects for printing.
Each function is called in turn with three arguments: the object, the
stream, and the print level (currently ignored). If it is able to
print the object it returns true; otherwise it returns nil and the
printer proceeds to the next function on the list.
This variable is not used at present, but it is defined in hopes that
a future Emacs interpreter will be able to use it.")
(defun cl-unload-function ()
"Stop unloading of the Common Lisp extensions."
(message "Cannot unload the feature `cl'")
;; stop standard unloading!
t)
;;; Generalized variables.
;; These macros are defined here so that they
;; can safely be used in .emacs files.
(defmacro incf (place &optional x)
"Increment PLACE by X (1 by default).
PLACE may be a symbol, or any generalized variable allowed by `setf'.
The return value is the incremented value of PLACE."
(declare (debug (place &optional form)))
(if (symbolp place)
(list 'setq place (if x (list '+ place x) (list '1+ place)))
(list 'callf '+ place (or x 1))))
(defmacro decf (place &optional x)
"Decrement PLACE by X (1 by default).
PLACE may be a symbol, or any generalized variable allowed by `setf'.
The return value is the decremented value of PLACE."
(declare (debug incf))
(if (symbolp place)
(list 'setq place (if x (list '- place x) (list '1- place)))
(list 'callf '- place (or x 1))))
;; Autoloaded, but we haven't loaded cl-loaddefs yet.
(declare-function cl-do-pop "cl-macs" (place))
(defmacro pop (place)
"Remove and return the head of the list stored in PLACE.
Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more
careful about evaluating each argument only once and in the right order.
PLACE may be a symbol, or any generalized variable allowed by `setf'."
(declare (debug (place)))
(if (symbolp place)
(list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))
(cl-do-pop place)))
(defmacro push (x place)
"Insert X at the head of the list stored in PLACE.
Analogous to (setf PLACE (cons X PLACE)), though more careful about
evaluating each argument only once and in the right order. PLACE may
be a symbol, or any generalized variable allowed by `setf'."
(declare (debug (form place)))
(if (symbolp place) (list 'setq place (list 'cons x place))
(list 'callf2 'cons x place)))
(defmacro pushnew (x place &rest keys)
"(pushnew X PLACE): insert X at the head of the list if not already there.
Like (push X PLACE), except that the list is unmodified if X is `eql' to
an element already on the list.
\nKeywords supported: :test :test-not :key
\n(fn X PLACE [KEYWORD VALUE]...)"
(declare (debug
(form place &rest
&or [[&or ":test" ":test-not" ":key"] function-form]
[keywordp form])))
(if (symbolp place)
(if (null keys)
`(let ((x ,x))
(if (memql x ,place)
;; This symbol may later on expand to actual code which then
;; trigger warnings like "value unused" since pushnew's return
;; value is rarely used. It should not matter that other
;; warnings may be silenced, since `place' is used earlier and
;; should have triggered them already.
(with-no-warnings ,place)
(setq ,place (cons x ,place))))
(list 'setq place (list* 'adjoin x place keys)))
(list* 'callf2 'adjoin x place keys)))
(defun cl-set-elt (seq n val)
(if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
(defsubst cl-set-nthcdr (n list x)
(if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
(defun cl-set-buffer-substring (start end val)
(save-excursion (delete-region start end)
(goto-char start)
(insert val)
val))
(defun cl-set-substring (str start end val)
(if end (if (< end 0) (incf end (length str)))
(setq end (length str)))
(if (< start 0) (incf start (length str)))
(concat (and (> start 0) (substring str 0 start))
val
(and (< end (length str)) (substring str end))))
;;; Control structures.
;; These macros are so simple and so often-used that it's better to have
;; them all the time than to load them from cl-macs.el.
(defun cl-map-extents (&rest cl-args)
(apply 'cl-map-overlays cl-args))
;;; Blocks and exits.
(defalias 'cl-block-wrapper 'identity)
(defalias 'cl-block-throw 'throw)
;;; Multiple values.
;; True multiple values are not supported, or even
;; simulated. Instead, multiple-value-bind and friends simply expect
;; the target form to return the values as a list.
(defsubst values (&rest values)
"Return multiple values, Common Lisp style.
The arguments of `values' are the values
that the containing function should return."
values)
(defsubst values-list (list)
"Return multiple values, Common Lisp style, taken from a list.
LIST specifies the list of values
that the containing function should return."
list)
(defsubst multiple-value-list (expression)
"Return a list of the multiple values produced by EXPRESSION.
This handles multiple values in Common Lisp style, but it does not
work right when EXPRESSION calls an ordinary Emacs Lisp function
that returns just one value."
expression)
(defsubst multiple-value-apply (function expression)
"Evaluate EXPRESSION to get multiple values and apply FUNCTION to them.
This handles multiple values in Common Lisp style, but it does not work
right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
one value."
(apply function expression))
(defalias 'multiple-value-call 'apply
"Apply FUNCTION to ARGUMENTS, taking multiple values into account.
This implementation only handles the case where there is only one argument.")
(defsubst nth-value (n expression)
"Evaluate EXPRESSION to get multiple values and return the Nth one.
This handles multiple values in Common Lisp style, but it does not work
right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
one value."
(nth n expression))
;;; Macros.
(defvar cl-macro-environment)
(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand)
(defalias 'macroexpand 'cl-macroexpand)))
(defun cl-macroexpand (cl-macro &optional cl-env)
"Return result of expanding macros at top level of FORM.
If FORM is not a macro call, it is returned unchanged.
Otherwise, the macro is expanded and the expansion is considered
in place of FORM. When a non-macro-call results, it is returned.
The second optional arg ENVIRONMENT specifies an environment of macro
definitions to shadow the loaded ones for use in file byte-compilation.
\n(fn FORM &optional ENVIRONMENT)"
(let ((cl-macro-environment cl-env))
(while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
(and (symbolp cl-macro)
(cdr (assq (symbol-name cl-macro) cl-env))))
(setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))
cl-macro))
;;; Declarations.
(defvar cl-compiling-file nil)
(defun cl-compiling-file ()
(or cl-compiling-file
(and (boundp 'byte-compile--outbuffer)
(bufferp (symbol-value 'byte-compile--outbuffer))
(equal (buffer-name (symbol-value 'byte-compile--outbuffer))
" *Compiler Output*"))))
(defvar cl-proclaims-deferred nil)
(defun proclaim (spec)
(if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
(push spec cl-proclaims-deferred))
nil)
(defmacro declaim (&rest specs)
(let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x))))
specs)))
(if (cl-compiling-file) (list* 'eval-when '(compile load eval) body)
(cons 'progn body)))) ; avoid loading cl-macs.el for eval-when
;;; Symbols.
(defun cl-random-time ()
(let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
(while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i))))
v))
(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100))
;;; Numbers.
(defun floatp-safe (object)
"Return t if OBJECT is a floating point number.
On Emacs versions that lack floating-point support, this function
always returns nil."
(and (numberp object) (not (integerp object))))
(defun plusp (number)
"Return t if NUMBER is positive."
(> number 0))
(defun minusp (number)
"Return t if NUMBER is negative."
(< number 0))
(defun oddp (integer)
"Return t if INTEGER is odd."
(eq (logand integer 1) 1))
(defun evenp (integer)
"Return t if INTEGER is even."
(eq (logand integer 1) 0))
(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time)))
(defconst most-positive-float nil
"The largest value that a Lisp float can hold.
If your system supports infinities, this is the largest finite value.
For IEEE machines, this is approximately 1.79e+308.
Call `cl-float-limits' to set this.")
(defconst most-negative-float nil
"The largest negative value that a Lisp float can hold.
This is simply -`most-positive-float'.
Call `cl-float-limits' to set this.")
(defconst least-positive-float nil
"The smallest value greater than zero that a Lisp float can hold.
For IEEE machines, it is about 4.94e-324 if denormals are supported,
or 2.22e-308 if they are not.
Call `cl-float-limits' to set this.")
(defconst least-negative-float nil
"The smallest value less than zero that a Lisp float can hold.
This is simply -`least-positive-float'.
Call `cl-float-limits' to set this.")
(defconst least-positive-normalized-float nil
"The smallest normalized Lisp float greater than zero.
This is the smallest value for which IEEE denormalization does not lose
precision. For IEEE machines, this value is about 2.22e-308.
For machines that do not support the concept of denormalization
and gradual underflow, this constant equals `least-positive-float'.
Call `cl-float-limits' to set this.")
(defconst least-negative-normalized-float nil
"The smallest normalized Lisp float less than zero.
This is simply -`least-positive-normalized-float'.
Call `cl-float-limits' to set this.")
(defconst float-epsilon nil
"The smallest positive float that adds to 1.0 to give a distinct value.
Adding a number less than this to 1.0 returns 1.0 due to roundoff.
For IEEE machines, epsilon is about 2.22e-16.
Call `cl-float-limits' to set this.")
(defconst float-negative-epsilon nil
"The smallest positive float that subtracts from 1.0 to give a distinct value.
For IEEE machines, it is about 1.11e-16.
Call `cl-float-limits' to set this.")
;;; Sequence functions.
(defalias 'copy-seq 'copy-sequence)
(declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs))
(defun mapcar* (cl-func cl-x &rest cl-rest)
"Apply FUNCTION to each element of SEQ, and make a list of the results.
If there are several SEQs, FUNCTION is called with that many arguments,
and mapping stops as soon as the shortest list runs out. With just one
SEQ, this is like `mapcar'. With several, it is like the Common Lisp
`mapcar' function extended to arbitrary sequence types.
\n(fn FUNCTION SEQ...)"
(if cl-rest
(if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
(cl-mapcar-many cl-func (cons cl-x cl-rest))
(let ((cl-res nil) (cl-y (car cl-rest)))
(while (and cl-x cl-y)
(push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
(nreverse cl-res)))
(mapcar cl-func cl-x)))
(defalias 'svref 'aref)
;;; List functions.
(defalias 'first 'car)
(defalias 'second 'cadr)
(defalias 'rest 'cdr)
(defalias 'endp 'null)
(defun third (x)
"Return the third element of the list X."
(car (cdr (cdr x))))
(defun fourth (x)
"Return the fourth element of the list X."
(nth 3 x))
(defun fifth (x)
"Return the fifth element of the list X."
(nth 4 x))
(defun sixth (x)
"Return the sixth element of the list X."
(nth 5 x))
(defun seventh (x)
"Return the seventh element of the list X."
(nth 6 x))
(defun eighth (x)
"Return the eighth element of the list X."
(nth 7 x))
(defun ninth (x)
"Return the ninth element of the list X."
(nth 8 x))
(defun tenth (x)
"Return the tenth element of the list X."
(nth 9 x))
(defun caaar (x)
"Return the `car' of the `car' of the `car' of X."
(car (car (car x))))
(defun caadr (x)
"Return the `car' of the `car' of the `cdr' of X."
(car (car (cdr x))))
(defun cadar (x)
"Return the `car' of the `cdr' of the `car' of X."
(car (cdr (car x))))
(defun caddr (x)
"Return the `car' of the `cdr' of the `cdr' of X."
(car (cdr (cdr x))))
(defun cdaar (x)
"Return the `cdr' of the `car' of the `car' of X."
(cdr (car (car x))))
(defun cdadr (x)
"Return the `cdr' of the `car' of the `cdr' of X."
(cdr (car (cdr x))))
(defun cddar (x)
"Return the `cdr' of the `cdr' of the `car' of X."
(cdr (cdr (car x))))
(defun cdddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of X."
(cdr (cdr (cdr x))))
(defun caaaar (x)
"Return the `car' of the `car' of the `car' of the `car' of X."
(car (car (car (car x)))))
(defun caaadr (x)
"Return the `car' of the `car' of the `car' of the `cdr' of X."
(car (car (car (cdr x)))))
(defun caadar (x)
"Return the `car' of the `car' of the `cdr' of the `car' of X."
(car (car (cdr (car x)))))
(defun caaddr (x)
"Return the `car' of the `car' of the `cdr' of the `cdr' of X."
(car (car (cdr (cdr x)))))
(defun cadaar (x)
"Return the `car' of the `cdr' of the `car' of the `car' of X."
(car (cdr (car (car x)))))
(defun cadadr (x)
"Return the `car' of the `cdr' of the `car' of the `cdr' of X."
(car (cdr (car (cdr x)))))
(defun caddar (x)
"Return the `car' of the `cdr' of the `cdr' of the `car' of X."
(car (cdr (cdr (car x)))))
(defun cadddr (x)
"Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
(car (cdr (cdr (cdr x)))))
(defun cdaaar (x)
"Return the `cdr' of the `car' of the `car' of the `car' of X."
(cdr (car (car (car x)))))
(defun cdaadr (x)
"Return the `cdr' of the `car' of the `car' of the `cdr' of X."
(cdr (car (car (cdr x)))))
(defun cdadar (x)
"Return the `cdr' of the `car' of the `cdr' of the `car' of X."
(cdr (car (cdr (car x)))))
(defun cdaddr (x)
"Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
(cdr (car (cdr (cdr x)))))
(defun cddaar (x)
"Return the `cdr' of the `cdr' of the `car' of the `car' of X."
(cdr (cdr (car (car x)))))
(defun cddadr (x)
"Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
(cdr (cdr (car (cdr x)))))
(defun cdddar (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
(cdr (cdr (cdr (car x)))))
(defun cddddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
(cdr (cdr (cdr (cdr x)))))
;;(defun last* (x &optional n)
;; "Returns the last link in the list LIST.
;;With optional argument N, returns Nth-to-last link (default 1)."
;; (if n
;; (let ((m 0) (p x))
;; (while (consp p) (incf m) (pop p))
;; (if (<= n 0) p
;; (if (< n m) (nthcdr (- m n) x) x)))
;; (while (consp (cdr x)) (pop x))
;; x))
(defun list* (arg &rest rest) ; See compiler macro in cl-macs.el
"Return a new list with specified ARGs as elements, consed to last ARG.
Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
`(cons A (cons B (cons C D)))'.
\n(fn ARG...)"
(cond ((not rest) arg)
((not (cdr rest)) (cons arg (car rest)))
(t (let* ((n (length rest))
(copy (copy-sequence rest))
(last (nthcdr (- n 2) copy)))
(setcdr last (car (cdr last)))
(cons arg copy)))))
(defun ldiff (list sublist)
"Return a copy of LIST with the tail SUBLIST removed."
(let ((res nil))
(while (and (consp list) (not (eq list sublist)))
(push (pop list) res))
(nreverse res)))
(defun copy-list (list)
"Return a copy of LIST, which may be a dotted list.
The elements of LIST are not copied, just the list structure itself."
(if (consp list)
(let ((res nil))
(while (consp list) (push (pop list) res))
(prog1 (nreverse res) (setcdr res list)))
(car list)))
(defun cl-maclisp-member (item list)
(while (and list (not (equal item (car list)))) (setq list (cdr list)))
list)
(defalias 'cl-member 'memq) ; for compatibility with old CL package
;; Autoloaded, but we have not loaded cl-loaddefs yet.
(declare-function floor* "cl-extra" (x &optional y))
(declare-function ceiling* "cl-extra" (x &optional y))
(declare-function truncate* "cl-extra" (x &optional y))
(declare-function round* "cl-extra" (x &optional y))
(declare-function mod* "cl-extra" (x y))
(defalias 'cl-floor 'floor*)
(defalias 'cl-ceiling 'ceiling*)
(defalias 'cl-truncate 'truncate*)
(defalias 'cl-round 'round*)
(defalias 'cl-mod 'mod*)
(defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs
"Return ITEM consed onto the front of LIST only if it's not already there.
Otherwise, return LIST unmodified.
\nKeywords supported: :test :test-not :key
\n(fn ITEM LIST [KEYWORD VALUE]...)"
(cond ((or (equal cl-keys '(:test eq))
(and (null cl-keys) (not (numberp cl-item))))
(if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
((or (equal cl-keys '(:test equal)) (null cl-keys))
(if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
(t (apply 'cl--adjoin cl-item cl-list cl-keys))))
(defun subst (cl-new cl-old cl-tree &rest cl-keys)
"Substitute NEW for OLD everywhere in TREE (non-destructively).
Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
\nKeywords supported: :test :test-not :key
\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
(if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
(apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
(cl-do-subst cl-new cl-old cl-tree)))
(defun cl-do-subst (cl-new cl-old cl-tree)
(cond ((eq cl-tree cl-old) cl-new)
((consp cl-tree)
(let ((a (cl-do-subst cl-new cl-old (car cl-tree)))
(d (cl-do-subst cl-new cl-old (cdr cl-tree))))
(if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
cl-tree (cons a d))))
(t cl-tree)))
(defun acons (key value alist)
"Add KEY and VALUE to ALIST.
Return a new list with (cons KEY VALUE) as car and ALIST as cdr."
(cons (cons key value) alist))
(defun pairlis (keys values &optional alist)
"Make an alist from KEYS and VALUES.
Return a new alist composed by associating KEYS to corresponding VALUES;
the process stops as soon as KEYS or VALUES run out.
If ALIST is non-nil, the new pairs are prepended to it."
(nconc (mapcar* 'cons keys values) alist))
;;; Miscellaneous.
;; Autoload the other portions of the package.
;; We want to replace the basic versions of dolist, dotimes, declare below.
(fmakunbound 'dolist)
(fmakunbound 'dotimes)
(fmakunbound 'declare)
;;;###autoload
(progn
;; Autoload, so autoload.el and font-lock can use it even when CL
;; is not loaded.
(put 'defun* 'doc-string-elt 3)
(put 'defmacro* 'doc-string-elt 3)
(put 'defsubst 'doc-string-elt 3)
(put 'defstruct 'doc-string-elt 2))
(load "cl-loaddefs" nil 'quiet)
;; This goes here so that cl-macs can find it if it loads right now.
(provide 'cl)
;; Things to do after byte-compiler is loaded.
(defvar cl-hacked-flag nil)
(defun cl-hack-byte-compiler ()
(and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)
(progn
(setq cl-hacked-flag t) ; Do it first, to prevent recursion.
(load "cl-macs" nil t)
(run-hooks 'cl-hack-bytecomp-hook))))
;; Try it now in case the compiler has already been loaded.
(cl-hack-byte-compiler)
;; Also make a hook in case compiler is loaded after this file.
(add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler)
;; The following ensures that packages which expect the old-style cl.el
;; will be happy with this one.
(require 'cl-lib)
;; (defun cl--rename ()
;; (let ((vdefs ())
;; (fdefs ())
;; (case-fold-search nil)
;; (files '("cl.el" "cl-macs.el" "cl-seq.el" "cl-extra.el")))
;; (dolist (file files)
;; (with-current-buffer (find-file-noselect file)
;; (goto-char (point-min))
;; (while (re-search-forward
;; "^(\\(def[^ \t\n]*\\) +'?\\(\\(\\sw\\|\\s_\\)+\\)" nil t)
;; (let ((name (match-string-no-properties 2))
;; (type (match-string-no-properties 1)))
;; (unless (string-match-p "\\`cl-" name)
;; (cond
;; ((member type '("defvar" "defconst"))
;; (unless (member name vdefs) (push name vdefs)))
;; ((member type '("defun" "defsubst" "defalias" "defmacro"))
;; (unless (member name fdefs) (push name fdefs)))
;; ((member type '("def-edebug-spec" "defsetf" "define-setf-method"
;; "define-compiler-macro"))
;; nil)
;; (t (error "Unknown type %S" type))))))))
;; (let ((re (concat "\\_<" (regexp-opt (append vdefs fdefs)) "\\_>"))
;; (conflicts ()))
;; (dolist (file files)
;; (with-current-buffer (find-file-noselect file)
;; (goto-char (point-min))
;; (while (re-search-forward re nil t)
;; (replace-match "cl-\\&"))
;; (save-buffer))))
;; (with-current-buffer (find-file-noselect "cl-rename.el")
;; (dolist (def vdefs)
;; (insert (format "(defvaralias '%s 'cl-%s)\n" def def)))
;; (dolist (def fdefs)
;; (insert (format "(defalias '%s 'cl-%s)\n" def def)))
;; (save-buffer))))
;; (defun cl--unrename ()
;; ;; Taken from "Naming Conventions" node of the doc.
;; (let* ((names '(defun* defsubst* defmacro* function* member*
;; assoc* rassoc* get* remove* delete*
;; mapcar* sort* floor* ceiling* truncate*
;; round* mod* rem* random*))
;; (files '("cl.el" "cl-lib.el" "cl-macs.el" "cl-seq.el" "cl-extra.el"))
;; (re (concat "\\_<cl-" (regexp-opt (mapcar #'symbol-name names))
;; "\\_>")))
;; (dolist (file files)
;; (with-current-buffer (find-file-noselect file)
;; (goto-char (point-min))
;; (while (re-search-forward re nil t)
;; (delete-region (1- (point)) (point)))
;; (save-buffer)))))
(dolist (var '(
;; loop-result-var
;; loop-result
;; loop-initially
;; loop-finally
;; loop-bindings
;; loop-args
;; bind-inits
;; bind-block
;; lambda-list-keywords
float-negative-epsilon
float-epsilon
least-negative-normalized-float
least-positive-normalized-float
least-negative-float
least-positive-float
most-negative-float
most-positive-float
;; custom-print-functions
))
(defvaralias var (intern (format "cl-%s" var))))
(dolist (fun '(
(get* . cl-get)
(random* . cl-random)
(rem* . cl-rem)
(mod* . cl-mod)
(round* . cl-round)
(truncate* . cl-truncate)
(ceiling* . cl-ceiling)
(floor* . cl-floor)
(rassoc* . cl-rassoc)
(assoc* . cl-assoc)
(member* . cl-member)
(delete* . cl-delete)
(remove* . cl-remove)
(defsubst* . cl-defsubst)
(sort* . cl-sort)
(function* . cl-function)
(defmacro* . cl-defmacro)
(defun* . cl-defun)
(mapcar* . cl-mapcar)
remprop
getf
tailp
list-length
nreconc
revappend
concatenate
subseq
random-state-p
make-random-state
signum
isqrt
lcm
gcd
notevery
notany
every
some
mapcon
mapcan
mapl
maplist
map
equalp
coerce
tree-equal
nsublis
sublis
nsubst-if-not
nsubst-if
nsubst
subst-if-not
subst-if
subsetp
nset-exclusive-or
set-exclusive-or
nset-difference
set-difference
nintersection
intersection
nunion
union
rassoc-if-not
rassoc-if
assoc-if-not
assoc-if
member-if-not
member-if
merge
stable-sort
search
mismatch
count-if-not
count-if
count
position-if-not
position-if
position
find-if-not
find-if
find
nsubstitute-if-not
nsubstitute-if
nsubstitute
substitute-if-not
substitute-if
substitute
delete-duplicates
remove-duplicates
delete-if-not
delete-if
remove-if-not
remove-if
replace
fill
reduce
compiler-macroexpand
define-compiler-macro
assert
check-type
typep
deftype
defstruct
define-modify-macro
callf2
callf
letf*
letf
rotatef
shiftf
remf
psetf
setf
get-setf-method
defsetf
define-setf-expander
define-setf-method
declare
the
locally
multiple-value-setq
multiple-value-bind
lexical-let*
lexical-let
symbol-macrolet
macrolet
labels
flet
progv
psetq
do-all-symbols
do-symbols
dotimes
dolist
do*
do
loop
return-from
return
block
etypecase
typecase
ecase
case
load-time-value
eval-when
destructuring-bind
gentemp
gensym
pairlis
acons
subst
adjoin
copy-list
ldiff
list*
cddddr
cdddar
cddadr
cddaar
cdaddr
cdadar
cdaadr
cdaaar
cadddr
caddar
cadadr
cadaar
caaddr
caadar
caaadr
caaaar
cdddr
cddar
cdadr
cdaar
caddr
cadar
caadr
caaar
tenth
ninth
eighth
seventh
sixth
fifth
fourth
third
endp
rest
second
first
svref
copy-seq
evenp
oddp
minusp
plusp
floatp-safe
declaim
proclaim
nth-value
multiple-value-call
multiple-value-apply
multiple-value-list
values-list
values
pushnew
push
pop
decf
incf
))
(let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun)))
(intern (format "cl-%s" fun)))))
(defalias fun new)
;; If `cl-foo' is declare inline, then make `foo' inline as well, and
;; similarly, if `cl-foo' has a compiler-macro, make it available for `foo'
;; as well. Same for edebug specifications, indent rules and
;; doc-string position.
;; FIXME: For most of them, we should instead follow aliases
;; where applicable.
(dolist (prop '(byte-optimizer byte-compile cl-compiler-macro
doc-string-elt edebug-form-spec
lisp-indent-function))
(if (get new prop)
(put fun prop (get new prop))))))
(provide 'cl)
(run-hooks 'cl-load-hook)
;; Local variables:
;; byte-compile-dynamic: t
;; byte-compile-warnings: (not cl-functions)
;; End:
;;; cl.el ends here

4
lisp/emacs-lisp/macroexp.el
View File

@ -185,9 +185,9 @@ Assumes the caller has bound `macroexpand-all-environment'."
(and (symbolp fun)
(eq (get fun 'byte-compile)
'cl-byte-compile-compiler-macro)
(functionp 'compiler-macroexpand))))
(functionp 'cl-compiler-macroexpand))))
. ,_)
(let ((newform (with-no-warnings (compiler-macroexpand form))))
(let ((newform (with-no-warnings (cl-compiler-macroexpand form))))
(if (eq form newform)
(macroexpand-all-forms form 1)
(macroexpand-all-1 newform))))