From 7c1898a7b93053cd0431f46f02d82c0a31bfb8bf Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 3 Jun 2012 21:05:17 -0400 Subject: [PATCH] * lisp/emacs-lisp/cl-lib.el: Rename from cl.el. * 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. --- etc/NEWS | 12 + lisp/ChangeLog | 17 +- lisp/emacs-lisp/cl-extra.el | 206 +++--- lisp/emacs-lisp/cl-lib.el | 693 ++++++++++++++++++ lisp/emacs-lisp/cl-macs.el | 1355 ++++++++++++++++++----------------- lisp/emacs-lisp/cl-seq.el | 212 +++--- lisp/emacs-lisp/cl.el | 984 ++++++++----------------- lisp/emacs-lisp/macroexp.el | 4 +- 8 files changed, 1914 insertions(+), 1569 deletions(-) create mode 100644 lisp/emacs-lisp/cl-lib.el diff --git a/etc/NEWS b/etc/NEWS index 48233963048..858cde1ba04 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 389e5487602..1c728c06c1f 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2012-06-04 Stefan Monnier + + * 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 * emacs-lisp/authors.el (authors-aliases): Addition. @@ -18,14 +27,14 @@ 2012-06-03 Chong Yidong * 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 (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 diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 420480d16ea..db8f663a873 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -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 "")))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el new file mode 100644 index 00000000000..bb3fc5fde60 --- /dev/null +++ b/lisp/emacs-lisp/cl-lib.el @@ -0,0 +1,693 @@ +;;; cl-lib.el --- Common Lisp extensions for Emacs + +;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc. + +;; Author: Dave Gillespie +;; 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 . + +;;; 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 diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 87b447d936e..e1488ea0db4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -43,12 +43,12 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) (defmacro cl-pop2 (place) + (declare (debug edebug-sexps)) `(prog1 (car (cdr ,place)) (setq ,place (cdr (cdr ,place))))) -(put 'cl-pop2 'edebug-form-spec 'edebug-sexps) (defvar cl-optimize-safety) (defvar cl-optimize-speed) @@ -77,7 +77,7 @@ ;;; Check if no side effects, and executes quickly. (defun cl-simple-expr-p (x &optional size) (or size (setq size 10)) - (if (and (consp x) (not (memq (car x) '(quote function function*)))) + (if (and (consp x) (not (memq (car x) '(quote function cl-function)))) (and (symbolp (car x)) (or (memq (car x) cl-simple-funcs) (get (car x) 'side-effect-free)) @@ -95,7 +95,7 @@ ;;; Check if no side effects. (defun cl-safe-expr-p (x) - (or (not (and (consp x) (not (memq (car x) '(quote function function*))))) + (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) (and (symbolp (car x)) (or (memq (car x) cl-simple-funcs) (memq (car x) cl-safe-funcs) @@ -108,7 +108,7 @@ (defun cl-const-expr-p (x) (cond ((consp x) (or (eq (car x) 'quote) - (and (memq (car x) '(function function*)) + (and (memq (car x) '(function cl-function)) (or (symbolp (nth 1 x)) (and (eq (car-safe (nth 1 x)) 'lambda) 'func))))) ((symbolp x) (and (memq x '(nil t)) t)) @@ -138,12 +138,12 @@ ;;; Count number of times X refers to Y. Return nil for 0 times. (defun cl-expr-contains (x y) - ;; FIXME: This is naive, and it will count Y as referred twice in + ;; FIXME: This is naive, and it will cl-count Y as referred twice in ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on ;; non-macroexpanded code, so it may also miss some occurrences that would ;; only appear in the expanded code. (cond ((equal y x) 1) - ((and (consp x) (not (memq (car x) '(quote function function*)))) + ((and (consp x) (not (memq (car x) '(quote function cl-function)))) (let ((sum 0)) (while (consp x) (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) @@ -164,7 +164,7 @@ (defvar cl--gensym-counter) ;;;###autoload -(defun gensym (&optional prefix) +(defun cl-gensym (&optional prefix) "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) @@ -174,7 +174,7 @@ The name is made by appending a number to PREFIX, default \"G\"." (make-symbol (format "%s%d" pfix num)))) ;;;###autoload -(defun gentemp (&optional prefix) +(defun cl-gentemp (&optional prefix) "Generate a new interned symbol with a unique name. The name is made by appending a number to PREFIX, default \"G\"." (let ((pfix (if (stringp prefix) prefix "G")) @@ -187,7 +187,7 @@ The name is made by appending a number to PREFIX, default \"G\"." ;;; Program structure. (def-edebug-spec cl-declarations - (&rest ("declare" &rest sexp))) + (&rest ("cl-declare" &rest sexp))) (def-edebug-spec cl-declarations-or-string (&or stringp cl-declarations)) @@ -209,15 +209,15 @@ The name is made by appending a number to PREFIX, default \"G\"." (&or ([&or (symbolp arg) arg] &optional def-form arg) arg)) ;;;###autoload -(defmacro defun* (name args &rest body) +(defmacro cl-defun (name args &rest body) "Define NAME as a function. Like normal `defun', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +and BODY is implicitly surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as defun but use cl-lambda-list. - (&define [&or name ("setf" :name setf name)] + (&define [&or name ("cl-setf" :name cl-setf name)] cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -267,10 +267,10 @@ and BODY is implicitly surrounded by (block NAME ...). . [&or arg nil]))) ;;;###autoload -(defmacro defmacro* (name args &rest body) +(defmacro cl-defmacro (name args &rest body) "Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, -and BODY is implicitly surrounded by (block NAME ...). +and BODY is implicitly surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug @@ -287,16 +287,16 @@ and BODY is implicitly surrounded by (block NAME ...). ;;[&optional ("interactive" interactive)] def-body))) -;; Redefine function-form to also match function* +;; Redefine function-form to also match cl-function (def-edebug-spec function-form ;; form at the end could also handle "function", ;; but recognize it specially to avoid wrapping function forms. (&or ([&or "quote" "function"] &or symbolp lambda-expr) - ("function*" function*) + ("cl-function" cl-function) form)) ;;;###autoload -(defmacro function* (func) +(defmacro cl-function (func) "Introduce a function. Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions." @@ -312,7 +312,7 @@ its argument list allows full Common Lisp conventions." `(progn ,@(cdr (cdr (car res))) (put ',func ',prop #'(lambda . ,(cdr res)))))) -(defconst lambda-list-keywords +(defconst cl-lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) (defvar cl-macro-environment nil @@ -320,8 +320,8 @@ its argument list allows full Common Lisp conventions." It is a list of elements of the form either: - (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function. - (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.") -(defvar bind-block) (defvar bind-defs) (defvar bind-enquote) -(defvar bind-inits) (defvar bind-lets) (defvar bind-forms) +(defvar cl-bind-block) (defvar cl-bind-defs) (defvar cl-bind-enquote) +(defvar cl-bind-inits) (defvar cl-bind-lets) (defvar cl-bind-forms) (declare-function help-add-fundoc-usage "help-fns" (docstring arglist)) @@ -347,7 +347,7 @@ It is a list of elements of the form either: ((not (consp x)) x) ((memq state '(nil &rest)) (cl--make-usage-args x)) (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR). - (list* + (cl-list* (if (and (consp (car x)) (eq state '&key)) (list (caar x) (cl--make-usage-var (nth 1 (car x)))) (cl--make-usage-var (car x))) @@ -356,20 +356,20 @@ It is a list of elements of the form either: )))) arglist))) -(defun cl-transform-lambda (form bind-block) +(defun cl-transform-lambda (form cl-bind-block) (let* ((args (car form)) (body (cdr form)) (orig-args args) - (bind-defs nil) (bind-enquote nil) - (bind-inits nil) (bind-lets nil) (bind-forms nil) + (cl-bind-defs nil) (cl-bind-enquote nil) + (cl-bind-inits nil) (cl-bind-lets nil) (cl-bind-forms nil) (header nil) (simple-args nil)) (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare))) + (memq (car-safe (car body)) '(interactive cl-declare))) (push (pop body) header)) - (setq args (if (listp args) (copy-list args) (list '&rest args))) + (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq bind-defs args)) - bind-defs (cadr bind-defs))) - (if (setq bind-enquote (memq '&cl-quote args)) + (if (setq cl-bind-defs (cadr (memq '&cl-defs args))) + (setq args (delq '&cl-defs (delq cl-bind-defs args)) + cl-bind-defs (cadr cl-bind-defs))) + (if (setq cl-bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) (let* ((p (memq '&environment args)) (v (cadr p))) @@ -378,20 +378,20 @@ It is a list of elements of the form either: (while (and args (symbolp (car args)) (not (memq (car args) '(nil &rest &body &key &aux))) (not (and (eq (car args) '&optional) - (or bind-defs (consp (cadr args)))))) + (or cl-bind-defs (consp (cadr args)))))) (push (pop args) simple-args)) - (or (eq bind-block 'cl-none) - (setq body (list `(block ,bind-block ,@body)))) + (or (eq cl-bind-block 'cl-none) + (setq body (list `(cl-block ,cl-bind-block ,@body)))) (if (null args) - (list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) (if (memq '&optional simple-args) (push '&optional args)) (cl-do-arglist args nil (- (length simple-args) (if (memq '&optional simple-args) 1 0))) - (setq bind-lets (nreverse bind-lets)) - (list* (and bind-inits `(eval-when (compile load eval) - ,@(nreverse bind-inits))) + (setq cl-bind-lets (nreverse cl-bind-lets)) + (cl-list* (and cl-bind-inits `(cl-eval-when (compile load eval) + ,@(nreverse cl-bind-inits))) (nconc (nreverse simple-args) - (list '&rest (car (pop bind-lets)))) + (list '&rest (car (pop cl-bind-lets)))) (nconc (let ((hdr (nreverse header))) ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not @@ -404,16 +404,16 @@ It is a list of elements of the form either: (cons 'fn (cl--make-usage-args orig-args)))) hdr))) - (list `(let* ,bind-lets - ,@(nreverse bind-forms) + (list `(let* ,cl-bind-lets + ,@(nreverse cl-bind-forms) ,@body))))))) (defun cl-do-arglist (args expr &optional num) ; uses bind-* (if (nlistp args) - (if (or (memq args lambda-list-keywords) (not (symbolp args))) + (if (or (memq args cl-lambda-list-keywords) (not (symbolp args))) (error "Invalid argument name: %s" args) - (push (list args expr) bind-lets)) - (setq args (copy-list args)) + (push (list args expr) cl-bind-lets)) + (setq args (cl-copy-list args)) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (let ((p (memq '&body args))) (if p (setcar p '&rest))) (if (memq '&environment args) (error "&environment used incorrectly")) @@ -426,19 +426,19 @@ It is a list of elements of the form either: (if (listp (cadr restarg)) (setq restarg (make-symbol "--cl-rest--")) (setq restarg (cadr restarg))) - (push (list restarg expr) bind-lets) + (push (list restarg expr) cl-bind-lets) (if (eq (car args) '&whole) - (push (list (cl-pop2 args) restarg) bind-lets)) + (push (list (cl-pop2 args) restarg) cl-bind-lets)) (let ((p args)) (setq minarg restarg) - (while (and p (not (memq (car p) lambda-list-keywords))) + (while (and p (not (memq (car p) cl-lambda-list-keywords))) (or (eq p args) (setq minarg (list 'cdr minarg))) (setq p (cdr p))) (if (memq (car p) '(nil &aux)) (setq minarg `(= (length ,restarg) - ,(length (ldiff args p))) + ,(length (cl-ldiff args p))) exactarg (not (eq args p))))) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) restarg))) (cl-do-arglist @@ -446,20 +446,20 @@ It is a list of elements of the form either: (if (or laterarg (= safety 0)) poparg `(if ,minarg ,poparg (signal 'wrong-number-of-arguments - (list ,(and (not (eq bind-block 'cl-none)) - `',bind-block) + (list ,(and (not (eq cl-bind-block 'cl-none)) + `',cl-bind-block) (length ,restarg))))))) (setq num (1+ num) laterarg t)) (while (and (eq (car args) '&optional) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) (if (cddr arg) (cl-do-arglist (nth 2 arg) `(and ,restarg t))) (let ((def (if (cdr arg) (nth 1 arg) - (or (car bind-defs) - (nth 1 (assq (car arg) bind-defs))))) + (or (car cl-bind-defs) + (nth 1 (assq (car arg) cl-bind-defs))))) (poparg `(pop ,restarg))) - (and def bind-enquote (setq def `',def)) + (and def cl-bind-enquote (setq def `',def)) (cl-do-arglist (car arg) (if def `(if ,restarg ,poparg ,def) poparg)) (setq num (1+ num)))))) @@ -470,21 +470,21 @@ It is a list of elements of the form either: (push `(if ,restarg (signal 'wrong-number-of-arguments (list - ,(and (not (eq bind-block 'cl-none)) - `',bind-block) + ,(and (not (eq cl-bind-block 'cl-none)) + `',cl-bind-block) (+ ,num (length ,restarg))))) - bind-forms))) + cl-bind-forms))) (while (and (eq (car args) '&key) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) (let* ((karg (if (consp (car arg)) (caar arg) (intern (format ":%s" (car arg))))) - (varg (if (consp (car arg)) (cadar arg) (car arg))) + (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) - (or (car bind-defs) (cadr (assq varg bind-defs))))) + (or (car cl-bind-defs) (cadr (assq varg cl-bind-defs))))) (look `(memq ',karg ,restarg))) - (and def bind-enquote (setq def `',def)) + (and def cl-bind-enquote (setq def `',def)) (if (cddr arg) (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) (val `(car (cdr ,temp)))) @@ -518,11 +518,11 @@ It is a list of elements of the form either: ,(format "Keyword argument %%s not one of %s" keys) (car ,var))))))) - (push `(let ((,var ,restarg)) ,check) bind-forms))) + (push `(let ((,var ,restarg)) ,check) cl-bind-forms))) (while (and (eq (car args) '&aux) (pop args)) - (while (and args (not (memq (car args) lambda-list-keywords))) + (while (and args (not (memq (car args) cl-lambda-list-keywords))) (if (consp (car args)) - (if (and bind-enquote (cadar args)) + (if (and cl-bind-enquote (cl-cadar args)) (cl-do-arglist (caar args) `',(cadr (pop args))) (cl-do-arglist (caar args) (cadr (pop args)))) @@ -534,7 +534,7 @@ It is a list of elements of the form either: (let ((res nil) (kind nil) arg) (while (consp args) (setq arg (pop args)) - (if (memq arg lambda-list-keywords) (setq kind arg) + (if (memq arg cl-lambda-list-keywords) (setq kind arg) (if (eq arg '&cl-defs) (pop args) (and (consp arg) kind (setq arg (car arg))) (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) @@ -542,23 +542,23 @@ It is a list of elements of the form either: (nconc res (and args (list args)))))) ;;;###autoload -(defmacro destructuring-bind (args expr &rest body) +(defmacro cl-destructuring-bind (args expr &rest body) (declare (indent 2) (debug (&define cl-macro-list def-form cl-declarations def-body))) - (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) - (bind-defs nil) (bind-block 'cl-none) (bind-enquote nil)) + (let* ((cl-bind-lets nil) (cl-bind-forms nil) (cl-bind-inits nil) + (cl-bind-defs nil) (cl-bind-block 'cl-none) (cl-bind-enquote nil)) (cl-do-arglist (or args '(&aux)) expr) - (append '(progn) bind-inits - (list `(let* ,(nreverse bind-lets) - ,@(nreverse bind-forms) ,@body))))) + (append '(progn) cl-bind-inits + (list `(let* ,(nreverse cl-bind-lets) + ,@(nreverse cl-bind-forms) ,@body))))) -;;; The `eval-when' form. +;;; The `cl-eval-when' form. (defvar cl-not-toplevel nil) ;;;###autoload -(defmacro eval-when (when &rest body) +(defmacro cl-eval-when (when &rest body) "Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. @@ -580,23 +580,23 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (defun cl-compile-time-too (form) (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) (setq form (macroexpand - form (cons '(eval-when) byte-compile-macro-environment)))) + form (cons '(cl-eval-when) byte-compile-macro-environment)))) (cond ((eq (car-safe form) 'progn) (cons 'progn (mapcar 'cl-compile-time-too (cdr form)))) - ((eq (car-safe form) 'eval-when) + ((eq (car-safe form) 'cl-eval-when) (let ((when (nth 1 form))) (if (or (memq 'eval when) (memq :execute when)) - `(eval-when (compile ,@when) ,@(cddr form)) + `(cl-eval-when (compile ,@when) ,@(cddr form)) form))) (t (eval form) form))) ;;;###autoload -(defmacro load-time-value (form &optional read-only) +(defmacro cl-load-time-value (form &optional read-only) "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." (declare (debug (form &optional sexp))) (if (cl-compiling-file) - (let* ((temp (gentemp "--cl-load-time--")) + (let* ((temp (cl-gentemp "--cl-load-time--")) (set `(set ',temp ,form))) (if (and (fboundp 'byte-compile-file-form-defmumble) (boundp 'this-kind) (boundp 'that-one)) @@ -614,11 +614,11 @@ The result of the body appears to the compiler as a quoted constant." ;;; Conditional control structures. ;;;###autoload -(defmacro case (expr &rest clauses) +(defmacro cl-case (expr &rest clauses) "Eval EXPR and choose among clauses on that value. Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared against each key in each KEYLIST; the corresponding BODY is evaluated. -If no clause succeeds, case returns nil. A single atom may be used in +If no clause succeeds, cl-case returns nil. A single atom may be used in place of a KEYLIST of one atom. A KEYLIST of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. Key values are compared by `eql'. @@ -632,12 +632,12 @@ Key values are compared by `eql'. (function (lambda (c) (cons (cond ((memq (car c) '(t otherwise)) t) - ((eq (car c) 'ecase-error-flag) - `(error "ecase failed: %s, %s" + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-ecase failed: %s, %s" ,temp ',(reverse head-list))) ((listp (car c)) (setq head-list (append (car c) head-list)) - `(member* ,temp ',(car c))) + `(cl-member ,temp ',(car c))) (t (if (memq (car c) head-list) (error "Duplicate key in case: %s" @@ -650,19 +650,19 @@ Key values are compared by `eql'. `(let ((,temp ,expr)) ,body)))) ;;;###autoload -(defmacro ecase (expr &rest clauses) - "Like `case', but error if no case fits. +(defmacro cl-ecase (expr &rest clauses) + "Like `cl-case', but error if no cl-case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" - (declare (indent 1) (debug case)) - `(case ,expr ,@clauses (ecase-error-flag))) + (declare (indent 1) (debug cl-case)) + `(cl-case ,expr ,@clauses (cl--ecase-error-flag))) ;;;###autoload -(defmacro typecase (expr &rest clauses) +(defmacro cl-typecase (expr &rest clauses) "Evals EXPR, chooses among clauses on that value. Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it satisfies TYPE, the corresponding BODY is evaluated. If no clause succeeds, -typecase returns nil. A TYPE of t or `otherwise' is allowed only in the +cl-typecase returns nil. A TYPE of t or `otherwise' is allowed only in the final clause, and matches if no other keys match. \n(fn EXPR (TYPE BODY...)...)" (declare (indent 1) @@ -675,8 +675,8 @@ final clause, and matches if no other keys match. (function (lambda (c) (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'ecase-error-flag) - `(error "etypecase failed: %s, %s" + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-etypecase failed: %s, %s" ,temp ',(reverse type-list))) (t (push (car c) type-list) @@ -687,20 +687,20 @@ final clause, and matches if no other keys match. `(let ((,temp ,expr)) ,body)))) ;;;###autoload -(defmacro etypecase (expr &rest clauses) - "Like `typecase', but error if no case fits. +(defmacro cl-etypecase (expr &rest clauses) + "Like `cl-typecase', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (TYPE BODY...)...)" - (declare (indent 1) (debug typecase)) - `(typecase ,expr ,@clauses (ecase-error-flag))) + (declare (indent 1) (debug cl-typecase)) + `(cl-typecase ,expr ,@clauses (cl--ecase-error-flag))) ;;; Blocks and exits. ;;;###autoload -(defmacro block (name &rest body) +(defmacro cl-block (name &rest body) "Define a lexically-scoped block named NAME. -NAME may be any symbol. Code inside the BODY forms can call `return-from' +NAME may be any symbol. Code inside the BODY forms can call `cl-return-from' to jump prematurely out of the block. This differs from `catch' and `throw' in two respects: First, the NAME is an unevaluated symbol rather than a quoted symbol or other form; and second, NAME is lexically rather than @@ -714,16 +714,16 @@ called from BODY." ,@body)))) ;;;###autoload -(defmacro return (&optional result) +(defmacro cl-return (&optional result) "Return from the block named nil. -This is equivalent to `(return-from nil RESULT)'." +This is equivalent to `(cl-return-from nil RESULT)'." (declare (debug (&optional form))) - `(return-from nil ,result)) + `(cl-return-from nil ,result)) ;;;###autoload -(defmacro return-from (name &optional result) +(defmacro cl-return-from (name &optional result) "Return from the block named NAME. -This jumps out to the innermost enclosing `(block NAME ...)' form, +This jumps out to the innermost enclosing `(cl-block NAME ...)' form, returning RESULT from that form (or nil if RESULT is omitted). This is compatible with Common Lisp, but note that `defun' and `defmacro' do not create implicit blocks as they do in Common Lisp." @@ -732,18 +732,19 @@ This is compatible with Common Lisp, but note that `defun' and `(cl-block-throw ',name2 ,result))) -;;; The "loop" macro. +;;; The "cl-loop" macro. -(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars) -(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps) -(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag) -(defvar loop-initially) (defvar loop-map-form) (defvar loop-name) -(defvar loop-result) (defvar loop-result-explicit) -(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) +(defvar cl-loop-args) (defvar cl-loop-accum-var) (defvar cl-loop-accum-vars) +(defvar cl-loop-bindings) (defvar cl-loop-body) (defvar cl-loop-destr-temps) +(defvar cl-loop-finally) (defvar cl-loop-finish-flag) +(defvar cl-loop-first-flag) +(defvar cl-loop-initially) (defvar cl-loop-map-form) (defvar cl-loop-name) +(defvar cl-loop-result) (defvar cl-loop-result-explicit) +(defvar cl-loop-result-var) (defvar cl-loop-steps) (defvar cl-loop-symbol-macs) ;;;###autoload -(defmacro loop (&rest loop-args) - "The Common Lisp `loop' macro. +(defmacro cl-loop (&rest cl-loop-args) + "The Common Lisp `cl-loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR, @@ -758,65 +759,65 @@ Valid clauses are: \(fn CLAUSE...)" (declare (debug (&rest &or symbolp form))) - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args)))))) - `(block nil (while t ,@loop-args)) - (let ((loop-name nil) (loop-bindings nil) - (loop-body nil) (loop-steps nil) - (loop-result nil) (loop-result-explicit nil) - (loop-result-var nil) (loop-finish-flag nil) - (loop-accum-var nil) (loop-accum-vars nil) - (loop-initially nil) (loop-finally nil) - (loop-map-form nil) (loop-first-flag nil) - (loop-destr-temps nil) (loop-symbol-macs nil)) - (setq loop-args (append loop-args '(cl-end-loop))) - (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) - (if loop-finish-flag - (push `((,loop-finish-flag t)) loop-bindings)) - (if loop-first-flag - (progn (push `((,loop-first-flag t)) loop-bindings) - (push `(setq ,loop-first-flag nil) loop-steps))) - (let* ((epilogue (nconc (nreverse loop-finally) - (list (or loop-result-explicit loop-result)))) - (ands (cl-loop-build-ands (nreverse loop-body))) - (while-body (nconc (cadr ands) (nreverse loop-steps))) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list cl-loop-args)))))) + `(cl-block nil (while t ,@cl-loop-args)) + (let ((cl-loop-name nil) (cl-loop-bindings nil) + (cl-loop-body nil) (cl-loop-steps nil) + (cl-loop-result nil) (cl-loop-result-explicit nil) + (cl-loop-result-var nil) (cl-loop-finish-flag nil) + (cl-loop-accum-var nil) (cl-loop-accum-vars nil) + (cl-loop-initially nil) (cl-loop-finally nil) + (cl-loop-map-form nil) (cl-loop-first-flag nil) + (cl-loop-destr-temps nil) (cl-loop-symbol-macs nil)) + (setq cl-loop-args (append cl-loop-args '(cl-end-loop))) + (while (not (eq (car cl-loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) + (if cl-loop-finish-flag + (push `((,cl-loop-finish-flag t)) cl-loop-bindings)) + (if cl-loop-first-flag + (progn (push `((,cl-loop-first-flag t)) cl-loop-bindings) + (push `(setq ,cl-loop-first-flag nil) cl-loop-steps))) + (let* ((epilogue (nconc (nreverse cl-loop-finally) + (list (or cl-loop-result-explicit cl-loop-result)))) + (ands (cl-loop-build-ands (nreverse cl-loop-body))) + (while-body (nconc (cadr ands) (nreverse cl-loop-steps))) (body (append - (nreverse loop-initially) - (list (if loop-map-form - `(block --cl-finish-- - ,(subst + (nreverse cl-loop-initially) + (list (if cl-loop-map-form + `(cl-block --cl-finish-- + ,(cl-subst (if (eq (car ands) t) while-body (cons `(or ,(car ands) - (return-from --cl-finish-- + (cl-return-from --cl-finish-- nil)) while-body)) - '--cl-map loop-map-form)) + '--cl-map cl-loop-map-form)) `(while ,(car ands) ,@while-body))) - (if loop-finish-flag - (if (equal epilogue '(nil)) (list loop-result-var) - `((if ,loop-finish-flag - (progn ,@epilogue) ,loop-result-var))) + (if cl-loop-finish-flag + (if (equal epilogue '(nil)) (list cl-loop-result-var) + `((if ,cl-loop-finish-flag + (progn ,@epilogue) ,cl-loop-result-var))) epilogue)))) - (if loop-result-var (push (list loop-result-var) loop-bindings)) - (while loop-bindings - (if (cdar loop-bindings) - (setq body (list (cl-loop-let (pop loop-bindings) body t))) + (if cl-loop-result-var (push (list cl-loop-result-var) cl-loop-bindings)) + (while cl-loop-bindings + (if (cdar cl-loop-bindings) + (setq body (list (cl-loop-let (pop cl-loop-bindings) body t))) (let ((lets nil)) - (while (and loop-bindings - (not (cdar loop-bindings))) - (push (car (pop loop-bindings)) lets)) + (while (and cl-loop-bindings + (not (cdar cl-loop-bindings))) + (push (car (pop cl-loop-bindings)) lets)) (setq body (list (cl-loop-let lets body nil)))))) - (if loop-symbol-macs - (setq body (list `(symbol-macrolet ,loop-symbol-macs ,@body)))) - `(block ,loop-name ,@body))))) + (if cl-loop-symbol-macs + (setq body (list `(cl-symbol-macrolet ,cl-loop-symbol-macs ,@body)))) + `(cl-block ,cl-loop-name ,@body))))) -;; Below is a complete spec for loop, in several parts that correspond +;; Below is a complete spec for cl-loop, in several parts that correspond ;; to the syntax given in CLtL2. The specs do more than specify where ;; the forms are; it also specifies, as much as Edebug allows, all the -;; syntactically valid loop clauses. The disadvantage of this +;; syntactically valid cl-loop clauses. The disadvantage of this ;; completeness is rigidity, but the "for ... being" clause allows ;; arbitrary extensions of the form: [symbolp &rest &or symbolp form]. -;; (def-edebug-spec loop +;; (def-edebug-spec cl-loop ;; ([&optional ["named" symbolp]] ;; [&rest ;; &or @@ -962,64 +963,64 @@ Valid clauses are: (defun cl-parse-loop-clause () ; uses loop-* - (let ((word (pop loop-args)) + (let ((word (pop cl-loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs key-binding key-bindings))) (cond - ((null loop-args) - (error "Malformed `loop' macro")) + ((null cl-loop-args) + (error "Malformed `cl-loop' macro")) ((eq word 'named) - (setq loop-name (pop loop-args))) + (setq cl-loop-name (pop cl-loop-args))) ((eq word 'initially) - (if (memq (car loop-args) '(do doing)) (pop loop-args)) - (or (consp (car loop-args)) (error "Syntax error on `initially' clause")) - (while (consp (car loop-args)) - (push (pop loop-args) loop-initially))) + (if (memq (car cl-loop-args) '(do doing)) (pop cl-loop-args)) + (or (consp (car cl-loop-args)) (error "Syntax error on `initially' clause")) + (while (consp (car cl-loop-args)) + (push (pop cl-loop-args) cl-loop-initially))) ((eq word 'finally) - (if (eq (car loop-args) 'return) - (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil))) - (if (memq (car loop-args) '(do doing)) (pop loop-args)) - (or (consp (car loop-args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar loop-args) 'return) (null loop-name)) - (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil))) - (while (consp (car loop-args)) - (push (pop loop-args) loop-finally))))) + (if (eq (car cl-loop-args) 'return) + (setq cl-loop-result-explicit (or (cl-pop2 cl-loop-args) '(quote nil))) + (if (memq (car cl-loop-args) '(do doing)) (pop cl-loop-args)) + (or (consp (car cl-loop-args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar cl-loop-args) 'return) (null cl-loop-name)) + (setq cl-loop-result-explicit (or (nth 1 (pop cl-loop-args)) '(quote nil))) + (while (consp (car cl-loop-args)) + (push (pop cl-loop-args) cl-loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) (ands nil)) (while - ;; Use `gensym' rather than `make-symbol'. It's important that + ;; Use `cl-gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because ;; these vars get added to the cl-macro-environment. - (let ((var (or (pop loop-args) (gensym "--cl-var--")))) - (setq word (pop loop-args)) - (if (eq word 'being) (setq word (pop loop-args))) - (if (memq word '(the each)) (setq word (pop loop-args))) + (let ((var (or (pop cl-loop-args) (cl-gensym "--cl-var--")))) + (setq word (pop cl-loop-args)) + (if (eq word 'being) (setq word (pop cl-loop-args))) + (if (memq word '(the each)) (setq word (pop cl-loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in loop-args (cons '(buffer-list) loop-args))) + (setq word 'in cl-loop-args (cons '(buffer-list) cl-loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto above below by)) - (push word loop-args) - (if (memq (car loop-args) '(downto above)) - (error "Must specify `from' value for downward loop")) - (let* ((down (or (eq (car loop-args) 'downfrom) - (memq (caddr loop-args) '(downto above)))) - (excl (or (memq (car loop-args) '(above below)) - (memq (caddr loop-args) '(above below)))) - (start (and (memq (car loop-args) '(from upfrom downfrom)) - (cl-pop2 loop-args))) - (end (and (memq (car loop-args) + (push word cl-loop-args) + (if (memq (car cl-loop-args) '(downto above)) + (error "Must specify `from' value for downward cl-loop")) + (let* ((down (or (eq (car cl-loop-args) 'downfrom) + (memq (cl-caddr cl-loop-args) '(downto above)))) + (excl (or (memq (car cl-loop-args) '(above below)) + (memq (cl-caddr cl-loop-args) '(above below)))) + (start (and (memq (car cl-loop-args) '(from upfrom downfrom)) + (cl-pop2 cl-loop-args))) + (end (and (memq (car cl-loop-args) '(to upto downto above below)) - (cl-pop2 loop-args))) - (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args))) + (cl-pop2 cl-loop-args))) + (step (and (eq (car cl-loop-args) 'by) (cl-pop2 cl-loop-args))) (end-var (and (not (cl-const-expr-p end)) (make-symbol "--cl-var--"))) (step-var (and (not (cl-const-expr-p step)) @@ -1033,7 +1034,7 @@ Valid clauses are: (if end (push (list (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) loop-body)) + var (or end-var end)) cl-loop-body)) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -1042,21 +1043,21 @@ Valid clauses are: (let* ((on (eq word 'on)) (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) - (push (list temp (pop loop-args)) loop-for-bindings) - (push `(consp ,temp) loop-body) + (push (list temp (pop cl-loop-args)) loop-for-bindings) + (push `(consp ,temp) cl-loop-body) (if (eq word 'in-ref) - (push (list var `(car ,temp)) loop-symbol-macs) + (push (list var `(car ,temp)) cl-loop-symbol-macs) (or (eq temp var) (progn (push (list var nil) loop-for-bindings) (push (list var (if on temp `(car ,temp))) loop-for-sets)))) (push (list temp - (if (eq (car loop-args) 'by) - (let ((step (cl-pop2 loop-args))) + (if (eq (car cl-loop-args) 'by) + (let ((step (cl-pop2 cl-loop-args))) (if (and (memq (car-safe step) '(quote function - function*)) + cl-function)) (symbolp (nth 1 step))) (list (nth 1 step) temp) `(funcall ,step ,temp))) @@ -1064,22 +1065,22 @@ Valid clauses are: loop-for-steps))) ((eq word '=) - (let* ((start (pop loop-args)) - (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start))) + (let* ((start (pop cl-loop-args)) + (then (if (eq (car cl-loop-args) 'then) (cl-pop2 cl-loop-args) start))) (push (list var nil) loop-for-bindings) - (if (or ands (eq (car loop-args) 'and)) + (if (or ands (eq (car cl-loop-args) 'and)) (progn (push `(,var - (if ,(or loop-first-flag - (setq loop-first-flag + (if ,(or cl-loop-first-flag + (setq cl-loop-first-flag (make-symbol "--cl-var--"))) ,start ,var)) loop-for-sets) (push (list var then) loop-for-steps)) (push (list var (if (eq start then) start - `(if ,(or loop-first-flag - (setq loop-first-flag + `(if ,(or cl-loop-first-flag + (setq cl-loop-first-flag (make-symbol "--cl-var--"))) ,start ,then))) loop-for-sets)))) @@ -1087,27 +1088,27 @@ Valid clauses are: ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop loop-args)) loop-for-bindings) + (push (list temp-vec (pop cl-loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) loop-body) + (length ,temp-vec)) cl-loop-body) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) - loop-symbol-macs) + cl-loop-symbol-macs) (push (list var nil) loop-for-bindings) (push (list var `(aref ,temp-vec ,temp-idx)) loop-for-sets)))) ((memq word '(element elements)) - (let ((ref (or (memq (car loop-args) '(in-ref of-ref)) - (and (not (memq (car loop-args) '(in of))) + (let ((ref (or (memq (car cl-loop-args) '(in-ref of-ref)) + (and (not (memq (car cl-loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 loop-args)) + (seq (cl-pop2 cl-loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car loop-args) 'using) - (if (and (= (length (cadr loop-args)) 2) - (eq (caadr loop-args) 'index)) - (cadr (cl-pop2 loop-args)) + (temp-idx (if (eq (car cl-loop-args) 'using) + (if (and (= (length (cadr cl-loop-args)) 2) + (eq (cl-caadr cl-loop-args) 'index)) + (cadr (cl-pop2 cl-loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) @@ -1117,13 +1118,13 @@ Valid clauses are: (push (list temp-len `(length ,temp-seq)) loop-for-bindings) (push (list var `(elt ,temp-seq temp-idx)) - loop-symbol-macs) - (push `(< ,temp-idx ,temp-len) loop-body)) + cl-loop-symbol-macs) + (push `(< ,temp-idx ,temp-len) cl-loop-body)) (push (list var nil) loop-for-bindings) (push `(and ,temp-seq (or (consp ,temp-seq) (< ,temp-idx (length ,temp-seq)))) - loop-body) + cl-loop-body) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) (aref ,temp-seq ,temp-idx))) @@ -1132,33 +1133,33 @@ Valid clauses are: loop-for-steps))) ((memq word hash-types) - (or (memq (car loop-args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 loop-args)) - (other (if (eq (car loop-args) 'using) - (if (and (= (length (cadr loop-args)) 2) - (memq (caadr loop-args) hash-types) - (not (eq (caadr loop-args) word))) - (cadr (cl-pop2 loop-args)) + (or (memq (car cl-loop-args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 cl-loop-args)) + (other (if (eq (car cl-loop-args) 'using) + (if (and (= (length (cadr cl-loop-args)) 2) + (memq (cl-caadr cl-loop-args) hash-types) + (not (eq (cl-caadr cl-loop-args) word))) + (cadr (cl-pop2 cl-loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) (setq var (prog1 other (setq other var)))) - (setq loop-map-form + (setq cl-loop-map-form `(maphash (lambda (,var ,other) . --cl-map) ,table)))) ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) - (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))) - (setq loop-map-form + (let ((ob (and (memq (car cl-loop-args) '(in of)) (cl-pop2 cl-loop-args)))) + (setq cl-loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) - (while (memq (car loop-args) '(in of from to)) - (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) - ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) - (t (setq buf (cl-pop2 loop-args))))) - (setq loop-map-form + (while (memq (car cl-loop-args) '(in of from to)) + (cond ((eq (car cl-loop-args) 'from) (setq from (cl-pop2 cl-loop-args))) + ((eq (car cl-loop-args) 'to) (setq to (cl-pop2 cl-loop-args))) + (t (setq buf (cl-pop2 cl-loop-args))))) + (setq cl-loop-map-form `(cl-map-extents (lambda (,var ,(make-symbol "--cl-var--")) (progn . --cl-map) nil) @@ -1168,36 +1169,36 @@ Valid clauses are: (let ((buf nil) (prop nil) (from nil) (to nil) (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) - (while (memq (car loop-args) '(in of property from to)) - (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args))) - ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args))) - ((eq (car loop-args) 'property) - (setq prop (cl-pop2 loop-args))) - (t (setq buf (cl-pop2 loop-args))))) + (while (memq (car cl-loop-args) '(in of property from to)) + (cond ((eq (car cl-loop-args) 'from) (setq from (cl-pop2 cl-loop-args))) + ((eq (car cl-loop-args) 'to) (setq to (cl-pop2 cl-loop-args))) + ((eq (car cl-loop-args) 'property) + (setq prop (cl-pop2 cl-loop-args))) + (t (setq buf (cl-pop2 cl-loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) (push (list var `(cons ,var1 ,var2)) loop-for-sets)) - (setq loop-map-form + (setq cl-loop-map-form `(cl-map-intervals (lambda (,var1 ,var2) . --cl-map) ,buf ,prop ,from ,to)))) ((memq word key-types) - (or (memq (car loop-args) '(in of)) (error "Expected `of'")) - (let ((map (cl-pop2 loop-args)) - (other (if (eq (car loop-args) 'using) - (if (and (= (length (cadr loop-args)) 2) - (memq (caadr loop-args) key-types) - (not (eq (caadr loop-args) word))) - (cadr (cl-pop2 loop-args)) + (or (memq (car cl-loop-args) '(in of)) (error "Expected `of'")) + (let ((cl-map (cl-pop2 cl-loop-args)) + (other (if (eq (car cl-loop-args) 'using) + (if (and (= (length (cadr cl-loop-args)) 2) + (memq (cl-caadr cl-loop-args) key-types) + (not (eq (cl-caadr cl-loop-args) word))) + (cadr (cl-pop2 cl-loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) (setq var (prog1 other (setq other var)))) - (setq loop-map-form + (setq cl-loop-map-form `(,(if (memq word '(key-seq key-seqs)) 'cl-map-keymap-recursively 'map-keymap) - (lambda (,var ,other) . --cl-map) ,map)))) + (lambda (,var ,other) . --cl-map) ,cl-map)))) ((memq word '(frame frames screen screens)) (let ((temp (make-symbol "--cl-var--"))) @@ -1206,12 +1207,12 @@ Valid clauses are: (push (list temp nil) loop-for-bindings) (push `(prog1 (not (eq ,var ,temp)) (or ,temp (setq ,temp ,var))) - loop-body) + cl-loop-body) (push (list var `(next-frame ,var)) loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))) + (let ((scr (and (memq (car cl-loop-args) '(in of)) (cl-pop2 cl-loop-args))) (temp (make-symbol "--cl-var--")) (minip (make-symbol "--cl-minip--"))) (push (list var (if scr @@ -1221,14 +1222,14 @@ Valid clauses are: ;; If we started in the minibuffer, we need to ;; ensure that next-window will bring us back there ;; at some point. (Bug#7492). - ;; (Consider using walk-windows instead of loop if + ;; (Consider using walk-windows instead of cl-loop if ;; you care about such things.) (push (list minip `(minibufferp (window-buffer ,var))) loop-for-bindings) (push (list temp nil) loop-for-bindings) (push `(prog1 (not (eq ,var ,temp)) (or ,temp (setq ,temp ,var))) - loop-body) + cl-loop-body) (push (list var `(next-window ,var ,minip)) loop-for-steps))) @@ -1238,42 +1239,42 @@ Valid clauses are: (if handler (funcall handler var) (error "Expected a `for' preposition, found %s" word))))) - (eq (car loop-args) 'and)) + (eq (car cl-loop-args) 'and)) (setq ands t) - (pop loop-args)) + (pop cl-loop-args)) (if (and ands loop-for-bindings) - (push (nreverse loop-for-bindings) loop-bindings) - (setq loop-bindings (nconc (mapcar 'list loop-for-bindings) - loop-bindings))) + (push (nreverse loop-for-bindings) cl-loop-bindings) + (setq cl-loop-bindings (nconc (mapcar 'list loop-for-bindings) + cl-loop-bindings))) (if loop-for-sets (push `(progn ,(cl-loop-let (nreverse loop-for-sets) 'setq ands) - t) loop-body)) + t) cl-loop-body)) (if loop-for-steps - (push (cons (if ands 'psetq 'setq) + (push (cons (if ands 'cl-psetq 'setq) (apply 'append (nreverse loop-for-steps))) - loop-steps)))) + cl-loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop loop-args))) loop-bindings) - (push `(>= (setq ,temp (1- ,temp)) 0) loop-body))) + (push (list (list temp (pop cl-loop-args))) cl-loop-bindings) + (push `(>= (setq ,temp (1- ,temp)) 0) cl-loop-body))) ((memq word '(collect collecting)) - (let ((what (pop loop-args)) + (let ((what (pop cl-loop-args)) (var (cl-loop-handle-accum nil 'nreverse))) - (if (eq var loop-accum-var) - (push `(progn (push ,what ,var) t) loop-body) + (if (eq var cl-loop-accum-var) + (push `(progn (push ,what ,var) t) cl-loop-body) (push `(progn (setq ,var (nconc ,var (list ,what))) - t) loop-body)))) + t) cl-loop-body)))) ((memq word '(nconc nconcing append appending)) - (let ((what (pop loop-args)) + (let ((what (pop cl-loop-args)) (var (cl-loop-handle-accum nil 'nreverse))) (push `(progn (setq ,var - ,(if (eq var loop-accum-var) + ,(if (eq var cl-loop-accum-var) `(nconc (,(if (memq word '(nconc nconcing)) #'nreverse #'reverse) @@ -1281,133 +1282,133 @@ Valid clauses are: ,var) `(,(if (memq word '(nconc nconcing)) #'nconc #'append) - ,var ,what))) t) loop-body))) + ,var ,what))) t) cl-loop-body))) ((memq word '(concat concating)) - (let ((what (pop loop-args)) + (let ((what (pop cl-loop-args)) (var (cl-loop-handle-accum ""))) - (push `(progn (callf concat ,var ,what) t) loop-body))) + (push `(progn (cl-callf concat ,var ,what) t) cl-loop-body))) ((memq word '(vconcat vconcating)) - (let ((what (pop loop-args)) + (let ((what (pop cl-loop-args)) (var (cl-loop-handle-accum []))) - (push `(progn (callf vconcat ,var ,what) t) loop-body))) + (push `(progn (cl-callf vconcat ,var ,what) t) cl-loop-body))) ((memq word '(sum summing)) - (let ((what (pop loop-args)) + (let ((what (pop cl-loop-args)) (var (cl-loop-handle-accum 0))) - (push `(progn (incf ,var ,what) t) loop-body))) + (push `(progn (cl-incf ,var ,what) t) cl-loop-body))) ((memq word '(count counting)) - (let ((what (pop loop-args)) + (let ((what (pop cl-loop-args)) (var (cl-loop-handle-accum 0))) - (push `(progn (if ,what (incf ,var)) t) loop-body))) + (push `(progn (if ,what (cl-incf ,var)) t) cl-loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop loop-args)) + (let* ((what (pop cl-loop-args)) (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) (var (cl-loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) (push `(progn ,(if (eq temp what) set `(let ((,temp ,what)) ,set)) - t) loop-body))) + t) cl-loop-body))) ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop loop-args) - (and (eq (car loop-args) '=) (cl-pop2 loop-args))) + (while (progn (push (list (pop cl-loop-args) + (and (eq (car cl-loop-args) '=) (cl-pop2 cl-loop-args))) bindings) - (eq (car loop-args) 'and)) - (pop loop-args)) - (push (nreverse bindings) loop-bindings))) + (eq (car cl-loop-args) 'and)) + (pop cl-loop-args)) + (push (nreverse bindings) cl-loop-bindings))) ((eq word 'while) - (push (pop loop-args) loop-body)) + (push (pop cl-loop-args) cl-loop-body)) ((eq word 'until) - (push `(not ,(pop loop-args)) loop-body)) + (push `(not ,(pop cl-loop-args)) cl-loop-body)) ((eq word 'always) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,loop-finish-flag ,(pop loop-args)) loop-body) - (setq loop-result t)) + (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl-loop-finish-flag ,(pop cl-loop-args)) cl-loop-body) + (setq cl-loop-result t)) ((eq word 'never) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,loop-finish-flag (not ,(pop loop-args))) - loop-body) - (setq loop-result t)) + (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl-loop-finish-flag (not ,(pop cl-loop-args))) + cl-loop-body) + (setq cl-loop-result t)) ((eq word 'thereis) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--"))) - (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,loop-finish-flag - (not (setq ,loop-result-var ,(pop loop-args)))) - loop-body)) + (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl-loop-result-var (setq cl-loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl-loop-finish-flag + (not (setq ,cl-loop-result-var ,(pop cl-loop-args)))) + cl-loop-body)) ((memq word '(if when unless)) - (let* ((cond (pop loop-args)) - (then (let ((loop-body nil)) + (let* ((cond (pop cl-loop-args)) + (then (let ((cl-loop-body nil)) (cl-parse-loop-clause) - (cl-loop-build-ands (nreverse loop-body)))) - (else (let ((loop-body nil)) - (if (eq (car loop-args) 'else) - (progn (pop loop-args) (cl-parse-loop-clause))) - (cl-loop-build-ands (nreverse loop-body)))) + (cl-loop-build-ands (nreverse cl-loop-body)))) + (else (let ((cl-loop-body nil)) + (if (eq (car cl-loop-args) 'else) + (progn (pop cl-loop-args) (cl-parse-loop-clause))) + (cl-loop-build-ands (nreverse cl-loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car loop-args) 'end) (pop loop-args)) + (if (eq (car cl-loop-args) 'end) (pop cl-loop-args)) (if (eq word 'unless) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) (if (cl-expr-contains form 'it) (let ((temp (make-symbol "--cl-var--"))) - (push (list temp) loop-bindings) + (push (list temp) cl-loop-bindings) (setq form `(if (setq ,temp ,cond) - ,@(subst temp 'it form)))) + ,@(cl-subst temp 'it form)))) (setq form `(if ,cond ,@form))) - (push (if simple `(progn ,form t) form) loop-body)))) + (push (if simple `(progn ,form t) form) cl-loop-body)))) ((memq word '(do doing)) (let ((body nil)) - (or (consp (car loop-args)) (error "Syntax error on `do' clause")) - (while (consp (car loop-args)) (push (pop loop-args) body)) - (push (cons 'progn (nreverse (cons t body))) loop-body))) + (or (consp (car cl-loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car cl-loop-args)) (push (pop cl-loop-args) body)) + (push (cons 'progn (nreverse (cons t body))) cl-loop-body))) ((eq word 'return) - (or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--"))) - (or loop-result-var (setq loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,loop-result-var ,(pop loop-args) - ,loop-finish-flag nil) loop-body)) + (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-var--"))) + (or cl-loop-result-var (setq cl-loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl-loop-result-var ,(pop cl-loop-args) + ,cl-loop-finish-flag nil) cl-loop-body)) (t (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) - (or handler (error "Expected a loop keyword, found %s" word)) + (or handler (error "Expected a cl-loop keyword, found %s" word)) (funcall handler)))) - (if (eq (car loop-args) 'and) - (progn (pop loop-args) (cl-parse-loop-clause))))) + (if (eq (car cl-loop-args) 'and) + (progn (pop cl-loop-args) (cl-parse-loop-clause))))) (defun cl-loop-let (specs body par) ; uses loop-* (let ((p specs) (temps nil) (new nil)) - (while (and p (or (symbolp (car-safe (car p))) (null (cadar p)))) + (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p)))) (setq p (cdr p))) (and par p (progn (setq par nil p specs) (while p - (or (cl-const-expr-p (cadar p)) + (or (cl-const-expr-p (cl-cadar p)) (let ((temp (make-symbol "--cl-var--"))) - (push (list temp (cadar p)) temps) + (push (list temp (cl-cadar p)) temps) (setcar (cdar p) temp))) (setq p (cdr p))))) (while specs (if (and (consp (car specs)) (listp (caar specs))) (let* ((spec (caar specs)) (nspecs nil) (expr (cadr (pop specs))) - (temp (cdr (or (assq spec loop-destr-temps) + (temp (cdr (or (assq spec cl-loop-destr-temps) (car (push (cons spec (or (last spec 0) (make-symbol "--cl-var--"))) - loop-destr-temps)))))) + cl-loop-destr-temps)))))) (push (list temp expr) new) (while (consp spec) (push (list (pop spec) @@ -1416,25 +1417,25 @@ Valid clauses are: (setq specs (nconc (nreverse nspecs) specs))) (push (pop specs) new))) (if (eq body 'setq) - (let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new))))) + (let ((set (cons (if par 'cl-psetq 'setq) (apply 'nconc (nreverse new))))) (if temps `(let* ,(nreverse temps) ,set) set)) `(,(if par 'let 'let*) ,(nconc (nreverse temps) (nreverse new)) ,@body)))) (defun cl-loop-handle-accum (def &optional func) ; uses loop-* - (if (eq (car loop-args) 'into) - (let ((var (cl-pop2 loop-args))) - (or (memq var loop-accum-vars) - (progn (push (list (list var def)) loop-bindings) - (push var loop-accum-vars))) + (if (eq (car cl-loop-args) 'into) + (let ((var (cl-pop2 cl-loop-args))) + (or (memq var cl-loop-accum-vars) + (progn (push (list (list var def)) cl-loop-bindings) + (push var cl-loop-accum-vars))) var) - (or loop-accum-var + (or cl-loop-accum-var (progn - (push (list (list (setq loop-accum-var (make-symbol "--cl-var--")) def)) - loop-bindings) - (setq loop-result (if func (list func loop-accum-var) - loop-accum-var)) - loop-accum-var)))) + (push (list (list (setq cl-loop-accum-var (make-symbol "--cl-var--")) def)) + cl-loop-bindings) + (setq cl-loop-result (if func (list func cl-loop-accum-var) + cl-loop-accum-var)) + cl-loop-accum-var)))) (defun cl-loop-build-ands (clauses) (let ((ands nil) @@ -1446,7 +1447,7 @@ Valid clauses are: (setq clauses (cons (nconc (butlast (car clauses)) (if (eq (car-safe (cadr clauses)) 'progn) - (cdadr clauses) + (cl-cdadr clauses) (list (cadr clauses)))) (cddr clauses))) (setq body (cdr (butlast (pop clauses))))) @@ -1463,8 +1464,8 @@ Valid clauses are: ;;; Other iteration control structures. ;;;###autoload -(defmacro do (steps endtest &rest body) - "The Common Lisp `do' loop. +(defmacro cl-do (steps endtest &rest body) + "The Common Lisp `cl-do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" (declare (indent 2) @@ -1475,15 +1476,15 @@ Valid clauses are: (cl-expand-do-loop steps endtest body nil)) ;;;###autoload -(defmacro do* (steps endtest &rest body) - "The Common Lisp `do*' loop. +(defmacro cl-do* (steps endtest &rest body) + "The Common Lisp `cl-do*' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" - (declare (indent 2) (debug do)) + (declare (indent 2) (debug cl-do)) (cl-expand-do-loop steps endtest body t)) (defun cl-expand-do-loop (steps endtest body star) - `(block nil + `(cl-block nil (,(if star 'let* 'let) ,(mapcar (lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) steps) @@ -1496,12 +1497,12 @@ Valid clauses are: (setq sets (delq nil sets)) (and sets (list (cons (if (or star (not (cdr sets))) - 'setq 'psetq) + 'setq 'cl-psetq) (apply 'append sets)))))) ,@(or (cdr endtest) '(nil))))) ;;;###autoload -(defmacro dolist (spec &rest body) +(defmacro cl-dolist (spec &rest body) "Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. Then evaluate RESULT to get return value, default nil. @@ -1511,7 +1512,7 @@ An implicit nil block is established around the loop. (declare (debug ((symbolp form &optional form) cl-declarations body))) (let ((temp (make-symbol "--cl-dolist-temp--"))) ;; FIXME: Copy&pasted from subr.el. - `(block nil + `(cl-block nil ;; This is not a reliable test, but it does not matter because both ;; semantics are acceptable, tho one is slightly faster with dynamic ;; scoping and the other is slightly faster (and has cleaner semantics) @@ -1535,18 +1536,18 @@ An implicit nil block is established around the loop. `((setq ,(car spec) nil) ,@(cddr spec)))))))) ;;;###autoload -(defmacro dotimes (spec &rest body) +(defmacro cl-dotimes (spec &rest body) "Loop a certain number of times. Evaluate BODY with VAR bound to successive integers from 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get return value, default nil. \(fn (VAR COUNT [RESULT]) BODY...)" - (declare (debug dolist)) + (declare (debug cl-dolist)) (let ((temp (make-symbol "--cl-dotimes-temp--")) (end (nth 1 spec))) ;; FIXME: Copy&pasted from subr.el. - `(block nil + `(cl-block nil ;; This is not a reliable test, but it does not matter because both ;; semantics are acceptable, tho one is slightly faster with dynamic ;; scoping and the other has cleaner semantics. @@ -1565,11 +1566,11 @@ nil. (,(car spec) 0)) (while (< ,(car spec) ,temp) ,@body - (incf ,(car spec))) + (cl-incf ,(car spec))) ,@(cdr (cdr spec))))))) ;;;###autoload -(defmacro do-symbols (spec &rest body) +(defmacro cl-do-symbols (spec &rest body) "Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol from OBARRAY. @@ -1578,35 +1579,35 @@ from OBARRAY. (declare (indent 1) (debug ((symbolp &optional form form) cl-declarations body))) ;; Apparently this doesn't have an implicit block. - `(block nil + `(cl-block nil (let (,(car spec)) (mapatoms #'(lambda (,(car spec)) ,@body) ,@(and (cadr spec) (list (cadr spec)))) - ,(caddr spec)))) + ,(cl-caddr spec)))) ;;;###autoload -(defmacro do-all-symbols (spec &rest body) +(defmacro cl-do-all-symbols (spec &rest body) (declare (indent 1) (debug ((symbolp &optional form) cl-declarations body))) - `(do-symbols (,(car spec) nil ,(cadr spec)) ,@body)) + `(cl-do-symbols (,(car spec) nil ,(cadr spec)) ,@body)) ;;; Assignments. ;;;###autoload -(defmacro psetq (&rest args) +(defmacro cl-psetq (&rest args) "Set SYMs to the values VALs in parallel. This is like `setq', except that all VAL forms are evaluated (in order) before assigning any symbols SYM to the corresponding values. \(fn SYM VAL SYM VAL ...)" (declare (debug setq)) - (cons 'psetf args)) + (cons 'cl-psetf args)) ;;; Binding control structures. ;;;###autoload -(defmacro progv (symbols values &rest body) +(defmacro cl-progv (symbols values &rest body) "Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. Each symbol in the first list is bound to the corresponding value in the @@ -1621,7 +1622,7 @@ a `let' form, except that the list of symbols can be computed at run-time." ;;; This should really have some way to shadow 'byte-compile properties, etc. ;;;###autoload -(defmacro flet (bindings &rest body) +(defmacro cl-flet (bindings &rest body) "Make temporary function definitions. This is an analogue of `let' that operates on the function cell of FUNC rather than its value cell. The FORMs are evaluated with the specified @@ -1629,23 +1630,23 @@ function definitions in place, then the definitions are undone (the FUNCs go back to their previous definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug ((&rest (defun*)) cl-declarations body))) - `(letf* ,(mapcar + (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) + `(cl-letf* ,(mapcar (lambda (x) (if (or (and (fboundp (car x)) (eq (car-safe (symbol-function (car x))) 'macro)) (cdr (assq (car x) cl-macro-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func `(function* + (error "Use `cl-labels', not `cl-flet', to rebind macro names")) + (let ((func `(cl-function (lambda ,(cadr x) - (block ,(car x) ,@(cddr x)))))) + (cl-block ,(car x) ,@(cddr x)))))) (when (cl-compiling-file) ;; Bug#411. It would be nice to fix this. (and (get (car x) 'byte-compile) (error "Byte-compiling a redefinition of `%s' \ -will not work - use `labels' instead" (symbol-name (car x)))) +will not work - use `cl-labels' instead" (symbol-name (car x)))) ;; FIXME This affects the rest of the file, when it - ;; should be restricted to the flet body. + ;; should be restricted to the cl-flet body. (and (boundp 'byte-compile-function-environment) (push (cons (car x) (eval func)) byte-compile-function-environment))) @@ -1654,35 +1655,35 @@ will not work - use `labels' instead" (symbol-name (car x)))) ,@body)) ;;;###autoload -(defmacro labels (bindings &rest body) +(defmacro cl-labels (bindings &rest body) "Make temporary function bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard. +This is like `cl-flet', except the bindings are lexical instead of dynamic. +Unlike `cl-flet', this macro is fully compliant with the Common Lisp standard. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug flet)) + (declare (indent 1) (debug cl-flet)) (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) (while bindings - ;; Use `gensym' rather than `make-symbol'. It's important that + ;; Use `cl-gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because these ;; vars get added to the cl-macro-environment. - (let ((var (gensym "--cl-var--"))) + (let ((var (cl-gensym "--cl-var--"))) (push var vars) - (push `(function* (lambda . ,(cdar bindings))) sets) + (push `(cl-function (lambda . ,(cdar bindings))) sets) (push var sets) (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args) - `(list* 'funcall ',var + `(cl-list* 'funcall ',var cl-labels-args)) cl-macro-environment))) - (cl-macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) + (cl-macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body) cl-macro-environment))) ;; The following ought to have a better definition for use with newer ;; byte compilers. ;;;###autoload -(defmacro macrolet (bindings &rest body) +(defmacro cl-macrolet (bindings &rest body) "Make temporary macro definitions. -This is like `flet', but for macros instead of functions. +This is like `cl-flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" (declare (indent 1) @@ -1691,35 +1692,35 @@ This is like `flet', but for macros instead of functions. def-body)) cl-declarations body))) (if (cdr bindings) - `(macrolet (,(car bindings)) (macrolet ,(cdr bindings) ,@body)) + `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (cons 'progn body) (let* ((name (caar bindings)) (res (cl-transform-lambda (cdar bindings) name))) (eval (car res)) (cl-macroexpand-all (cons 'progn body) - (cons (list* name 'lambda (cdr res)) + (cons (cl-list* name 'lambda (cdr res)) cl-macro-environment)))))) ;;;###autoload -(defmacro symbol-macrolet (bindings &rest body) +(defmacro cl-symbol-macrolet (bindings &rest body) "Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced -by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). +by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) (if (cdr bindings) - `(symbol-macrolet (,(car bindings)) - (symbol-macrolet ,(cdr bindings) ,@body)) + `(cl-symbol-macrolet (,(car bindings)) + (cl-symbol-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (cons 'progn body) (cl-macroexpand-all (cons 'progn body) (cons (list (symbol-name (caar bindings)) - (cadar bindings)) + (cl-cadar bindings)) cl-macro-environment))))) (defvar cl-closure-vars nil) ;;;###autoload -(defmacro lexical-let (bindings &rest body) +(defmacro cl-lexical-let (bindings &rest body) "Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. @@ -1739,36 +1740,37 @@ lexical closures as in Common Lisp. (cons 'progn body) (nconc (mapcar (function (lambda (x) (list (symbol-name (car x)) - `(symbol-value ,(caddr x)) + `(symbol-value ,(cl-caddr x)) t))) vars) (list '(defun . cl-defun-expander)) cl-macro-environment)))) (if (not (get (car (last cl-closure-vars)) 'used)) - ;; Turn (let ((foo (gensym))) (set foo ) ...(symbol-value foo)...) + ;; Turn (let ((foo (cl-gensym))) + ;; (set foo ) ...(symbol-value foo)...) ;; into (let ((foo )) ...(symbol-value 'foo)...). ;; This is good because it's more efficient but it only works with ;; dynamic scoping, since with lexical scoping we'd need ;; (let ((foo )) ...foo...). `(progn - ,@(mapcar (lambda (x) `(defvar ,(caddr x))) vars) - (let ,(mapcar (lambda (x) (list (caddr x) (cadr x))) vars) - ,(sublis (mapcar (lambda (x) - (cons (caddr x) - `',(caddr x))) + ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars) + (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars) + ,(cl-sublis (mapcar (lambda (x) + (cons (cl-caddr x) + `',(cl-caddr x))) vars) ebody))) `(let ,(mapcar (lambda (x) - (list (caddr x) + (list (cl-caddr x) `(make-symbol ,(format "--%s--" (car x))))) vars) - (setf ,@(apply #'append + (cl-setf ,@(apply #'append (mapcar (lambda (x) - (list `(symbol-value ,(caddr x)) (cadr x))) + (list `(symbol-value ,(cl-caddr x)) (cadr x))) vars))) ,ebody)))) ;;;###autoload -(defmacro lexical-let* (bindings &rest body) +(defmacro cl-lexical-let* (bindings &rest body) "Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY, and in successive bindings within BINDINGS, will create lexical closures @@ -1779,7 +1781,7 @@ Common Lisp. (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings - (setq body (list `(lexical-let (,(pop bindings)) ,@body)))) + (setq body (list `(cl-lexical-let (,(pop bindings)) ,@body)))) (car body))) (defun cl-defun-expander (func &rest rest) @@ -1791,12 +1793,12 @@ Common Lisp. ;;; Multiple values. ;;;###autoload -(defmacro multiple-value-bind (vars form &rest body) +(defmacro cl-multiple-value-bind (vars form &rest body) "Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements of this list bound (`let'-style) to each of the symbols SYM in turn. This -is analogous to the Common Lisp `multiple-value-bind' macro, using lists to -simulate true multiple return values. For compatibility, (values A B C) is +is analogous to the Common Lisp `cl-multiple-value-bind' macro, using lists to +simulate true multiple return values. For compatibility, (cl-values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM BODY)" @@ -1809,12 +1811,12 @@ a synonym for (list A B C). ,@body))) ;;;###autoload -(defmacro multiple-value-setq (vars form) +(defmacro cl-multiple-value-setq (vars form) "Collect multiple return values. FORM must return a list; the first N elements of this list are stored in each of the symbols SYM in turn. This is analogous to the Common Lisp -`multiple-value-setq' macro, using lists to simulate true multiple return -values. For compatibility, (values A B C) is a synonym for (list A B C). +`cl-multiple-value-setq' macro, using lists to simulate true multiple return +values. For compatibility, (cl-values A B C) is a synonym for (list A B C). \(fn (SYM...) FORM)" (declare (indent 1) (debug ((&rest symbolp) form))) @@ -1834,11 +1836,11 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ;;; Declarations. ;;;###autoload -(defmacro locally (&rest body) +(defmacro cl-locally (&rest body) (declare (debug t)) (cons 'progn body)) ;;;###autoload -(defmacro the (type form) +(defmacro cl-the (type form) (declare (indent 1) (debug (cl-type-spec form))) form) @@ -1879,7 +1881,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) (while (setq spec (cdr spec)) (if (consp (car spec)) - (if (eq (cadar spec) 0) + (if (eq (cl-cadar spec) 0) (byte-compile-disable-warning (caar spec)) (byte-compile-enable-warning (caar spec))))))) nil) @@ -1891,11 +1893,11 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). (setq cl-proclaims-deferred nil)) ;;;###autoload -(defmacro declare (&rest specs) +(defmacro cl-declare (&rest specs) "Declare SPECS about the current function while compiling. For instance - \(declare (warn 0)) + \(cl-declare (warn 0)) will turn off byte-compile warnings in the function. See Info node `(cl)Declarations' for details." @@ -1910,44 +1912,44 @@ See Info node `(cl)Declarations' for details." ;;; Generalized variables. ;;;###autoload -(defmacro define-setf-method (func args &rest body) - "Define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). +(defmacro cl-define-setf-method (func args &rest body) + "Define a `cl-setf' method. +This method shows how to handle `cl-setf's to places of the form (NAME ARGS...). The argument forms ARGS are bound according to ARGLIST, as if NAME were going to be expanded as a macro, then the BODY forms are executed and must return a list of five elements: a temporary-variables list, a value-forms list, a store-variables list (of length one), a store-form, and an access- -form. See `defsetf' for a simpler way to define most setf-methods. +form. See `cl-defsetf' for a simpler way to define most setf-methods. \(fn NAME ARGLIST BODY...)" (declare (debug (&define name cl-lambda-list cl-declarations-or-string def-body))) - `(eval-when (compile load eval) + `(cl-eval-when (compile load eval) ,@(if (stringp (car body)) (list `(put ',func 'setf-documentation ,(pop body)))) ,(cl-transform-function-property func 'setf-method (cons args body)))) -(defalias 'define-setf-expander 'define-setf-method) +(defalias 'cl-define-setf-expander 'cl-define-setf-method) ;;;###autoload -(defmacro defsetf (func arg1 &rest args) - "Define a `setf' method. -This macro is an easy-to-use substitute for `define-setf-method' that works -well for simple place forms. In the simple `defsetf' form, `setf's of -the form (setf (NAME ARGS...) VAL) are transformed to function or macro +(defmacro cl-defsetf (func arg1 &rest args) + "Define a `cl-setf' method. +This macro is an easy-to-use substitute for `cl-define-setf-method' that works +well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of +the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro calls of the form (FUNC ARGS... VAL). Example: - (defsetf aref aset) + (cl-defsetf aref aset) -Alternate form: (defsetf NAME ARGLIST (STORE) BODY...). -Here, the above `setf' call is expanded by binding the argument forms ARGS +Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...). +Here, the above `cl-setf' call is expanded by binding the argument forms ARGS according to ARGLIST, binding the value form VAL to STORE, then executing -BODY, which must return a Lisp form that does the necessary `setf' operation. +BODY, which must return a Lisp form that does the necessary `cl-setf' operation. Actually, ARGLIST and STORE may be bound to temporary variables which are introduced automatically to preserve proper execution order of the arguments. Example: - (defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) + (cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v)) \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" (declare (debug @@ -1988,7 +1990,7 @@ Example: lets2 (cons (list (car p1) (car p2)) lets2) p1 (cdr p1) p2 (cdr p2)))) (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) - `(define-setf-method ,func ,arg1 + `(cl-define-setf-method ,func ,arg1 ,@(and docstr (list docstr)) (let* ,(nreverse @@ -2001,17 +2003,17 @@ Example: ,@lets1) lets1))) (list ; 'values - (,(if restarg 'list* 'list) ,@tempsr) - (,(if restarg 'list* 'list) ,@largsr) + (,(if restarg 'cl-list* 'list) ,@tempsr) + (,(if restarg 'cl-list* 'list) ,@largsr) (list ,store-temp) (let* ,(nreverse (cons (list store-var store-temp) lets2)) ,@args) - (,(if restarg 'list* 'list) + (,(if restarg 'cl-list* 'list) ,@(cons `',func tempsr)))))) - `(defsetf ,func (&rest args) (store) + `(cl-defsetf ,func (&rest args) (store) ,(let ((call `(cons ',arg1 (append args (list store))))) (if (car args) @@ -2019,130 +2021,130 @@ Example: call))))) ;;; Some standard place types from Common Lisp. -(defsetf aref aset) -(defsetf car setcar) -(defsetf cdr setcdr) -(defsetf caar (x) (val) `(setcar (car ,x) ,val)) -(defsetf cadr (x) (val) `(setcar (cdr ,x) ,val)) -(defsetf cdar (x) (val) `(setcdr (car ,x) ,val)) -(defsetf cddr (x) (val) `(setcdr (cdr ,x) ,val)) -(defsetf elt (seq n) (store) +(cl-defsetf aref aset) +(cl-defsetf car setcar) +(cl-defsetf cdr setcdr) +(cl-defsetf caar (x) (val) `(setcar (car ,x) ,val)) +(cl-defsetf cadr (x) (val) `(setcar (cdr ,x) ,val)) +(cl-defsetf cdar (x) (val) `(setcdr (car ,x) ,val)) +(cl-defsetf cddr (x) (val) `(setcdr (cdr ,x) ,val)) +(cl-defsetf elt (seq n) (store) `(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store) (aset ,seq ,n ,store))) -(defsetf get put) -(defsetf get* (x y &optional d) (store) `(put ,x ,y ,store)) -(defsetf gethash (x h &optional d) (store) `(puthash ,x ,store ,h)) -(defsetf nth (n x) (store) `(setcar (nthcdr ,n ,x) ,store)) -(defsetf subseq (seq start &optional end) (new) - `(progn (replace ,seq ,new :start1 ,start :end1 ,end) ,new)) -(defsetf symbol-function fset) -(defsetf symbol-plist setplist) -(defsetf symbol-value set) +(cl-defsetf get put) +(cl-defsetf cl-get (x y &optional d) (store) `(put ,x ,y ,store)) +(cl-defsetf gethash (x h &optional d) (store) `(puthash ,x ,store ,h)) +(cl-defsetf nth (n x) (store) `(setcar (nthcdr ,n ,x) ,store)) +(cl-defsetf cl-subseq (seq start &optional end) (new) + `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) ,new)) +(cl-defsetf symbol-function fset) +(cl-defsetf symbol-plist setplist) +(cl-defsetf symbol-value set) ;;; Various car/cdr aliases. Note that `cadr' is handled specially. -(defsetf first setcar) -(defsetf second (x) (store) `(setcar (cdr ,x) ,store)) -(defsetf third (x) (store) `(setcar (cddr ,x) ,store)) -(defsetf fourth (x) (store) `(setcar (cdddr ,x) ,store)) -(defsetf fifth (x) (store) `(setcar (nthcdr 4 ,x) ,store)) -(defsetf sixth (x) (store) `(setcar (nthcdr 5 ,x) ,store)) -(defsetf seventh (x) (store) `(setcar (nthcdr 6 ,x) ,store)) -(defsetf eighth (x) (store) `(setcar (nthcdr 7 ,x) ,store)) -(defsetf ninth (x) (store) `(setcar (nthcdr 8 ,x) ,store)) -(defsetf tenth (x) (store) `(setcar (nthcdr 9 ,x) ,store)) -(defsetf rest setcdr) +(cl-defsetf cl-first setcar) +(cl-defsetf cl-second (x) (store) `(setcar (cdr ,x) ,store)) +(cl-defsetf cl-third (x) (store) `(setcar (cddr ,x) ,store)) +(cl-defsetf cl-fourth (x) (store) `(setcar (cl-cdddr ,x) ,store)) +(cl-defsetf cl-fifth (x) (store) `(setcar (nthcdr 4 ,x) ,store)) +(cl-defsetf cl-sixth (x) (store) `(setcar (nthcdr 5 ,x) ,store)) +(cl-defsetf cl-seventh (x) (store) `(setcar (nthcdr 6 ,x) ,store)) +(cl-defsetf cl-eighth (x) (store) `(setcar (nthcdr 7 ,x) ,store)) +(cl-defsetf cl-ninth (x) (store) `(setcar (nthcdr 8 ,x) ,store)) +(cl-defsetf cl-tenth (x) (store) `(setcar (nthcdr 9 ,x) ,store)) +(cl-defsetf cl-rest setcdr) ;;; Some more Emacs-related place types. -(defsetf buffer-file-name set-visited-file-name t) -(defsetf buffer-modified-p (&optional buf) (flag) +(cl-defsetf buffer-file-name set-visited-file-name t) +(cl-defsetf buffer-modified-p (&optional buf) (flag) `(with-current-buffer ,buf (set-buffer-modified-p ,flag))) -(defsetf buffer-name rename-buffer t) -(defsetf buffer-string () (store) +(cl-defsetf buffer-name rename-buffer t) +(cl-defsetf buffer-string () (store) `(progn (erase-buffer) (insert ,store))) -(defsetf buffer-substring cl-set-buffer-substring) -(defsetf current-buffer set-buffer) -(defsetf current-case-table set-case-table) -(defsetf current-column move-to-column t) -(defsetf current-global-map use-global-map t) -(defsetf current-input-mode () (store) +(cl-defsetf buffer-substring cl-set-buffer-substring) +(cl-defsetf current-buffer set-buffer) +(cl-defsetf current-case-table set-case-table) +(cl-defsetf current-column move-to-column t) +(cl-defsetf current-global-map use-global-map t) +(cl-defsetf current-input-mode () (store) `(progn (apply #'set-input-mode ,store) ,store)) -(defsetf current-local-map use-local-map t) -(defsetf current-window-configuration set-window-configuration t) -(defsetf default-file-modes set-default-file-modes t) -(defsetf default-value set-default) -(defsetf documentation-property put) -(defsetf face-background (f &optional s) (x) `(set-face-background ,f ,x ,s)) -(defsetf face-background-pixmap (f &optional s) (x) +(cl-defsetf current-local-map use-local-map t) +(cl-defsetf current-window-configuration set-window-configuration t) +(cl-defsetf default-file-modes set-default-file-modes t) +(cl-defsetf default-value set-default) +(cl-defsetf documentation-property put) +(cl-defsetf face-background (f &optional s) (x) `(set-face-background ,f ,x ,s)) +(cl-defsetf face-background-pixmap (f &optional s) (x) `(set-face-background-pixmap ,f ,x ,s)) -(defsetf face-font (f &optional s) (x) `(set-face-font ,f ,x ,s)) -(defsetf face-foreground (f &optional s) (x) `(set-face-foreground ,f ,x ,s)) -(defsetf face-underline-p (f &optional s) (x) +(cl-defsetf face-font (f &optional s) (x) `(set-face-font ,f ,x ,s)) +(cl-defsetf face-foreground (f &optional s) (x) `(set-face-foreground ,f ,x ,s)) +(cl-defsetf face-underline-p (f &optional s) (x) `(set-face-underline-p ,f ,x ,s)) -(defsetf file-modes set-file-modes t) -(defsetf frame-height set-screen-height t) -(defsetf frame-parameters modify-frame-parameters t) -(defsetf frame-visible-p cl-set-frame-visible-p) -(defsetf frame-width set-screen-width t) -(defsetf frame-parameter set-frame-parameter t) -(defsetf terminal-parameter set-terminal-parameter) -(defsetf getenv setenv t) -(defsetf get-register set-register) -(defsetf global-key-binding global-set-key) -(defsetf keymap-parent set-keymap-parent) -(defsetf local-key-binding local-set-key) -(defsetf mark set-mark t) -(defsetf mark-marker set-mark t) -(defsetf marker-position set-marker t) -(defsetf match-data set-match-data t) -(defsetf mouse-position (scr) (store) +(cl-defsetf file-modes set-file-modes t) +(cl-defsetf frame-height set-screen-height t) +(cl-defsetf frame-parameters modify-frame-parameters t) +(cl-defsetf frame-visible-p cl-set-frame-visible-p) +(cl-defsetf frame-width set-screen-width t) +(cl-defsetf frame-parameter set-frame-parameter t) +(cl-defsetf terminal-parameter set-terminal-parameter) +(cl-defsetf getenv setenv t) +(cl-defsetf get-register set-register) +(cl-defsetf global-key-binding global-set-key) +(cl-defsetf keymap-parent set-keymap-parent) +(cl-defsetf local-key-binding local-set-key) +(cl-defsetf mark set-mark t) +(cl-defsetf mark-marker set-mark t) +(cl-defsetf marker-position set-marker t) +(cl-defsetf match-data set-match-data t) +(cl-defsetf mouse-position (scr) (store) `(set-mouse-position ,scr (car ,store) (cadr ,store) (cddr ,store))) -(defsetf overlay-get overlay-put) -(defsetf overlay-start (ov) (store) +(cl-defsetf overlay-get overlay-put) +(cl-defsetf overlay-start (ov) (store) `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store)) -(defsetf overlay-end (ov) (store) +(cl-defsetf overlay-end (ov) (store) `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store)) -(defsetf point goto-char) -(defsetf point-marker goto-char t) -(defsetf point-max () (store) +(cl-defsetf point goto-char) +(cl-defsetf point-marker goto-char t) +(cl-defsetf point-max () (store) `(progn (narrow-to-region (point-min) ,store) ,store)) -(defsetf point-min () (store) +(cl-defsetf point-min () (store) `(progn (narrow-to-region ,store (point-max)) ,store)) -(defsetf process-buffer set-process-buffer) -(defsetf process-filter set-process-filter) -(defsetf process-sentinel set-process-sentinel) -(defsetf process-get process-put) -(defsetf read-mouse-position (scr) (store) +(cl-defsetf process-buffer set-process-buffer) +(cl-defsetf process-filter set-process-filter) +(cl-defsetf process-sentinel set-process-sentinel) +(cl-defsetf process-get process-put) +(cl-defsetf read-mouse-position (scr) (store) `(set-mouse-position ,scr (car ,store) (cdr ,store))) -(defsetf screen-height set-screen-height t) -(defsetf screen-width set-screen-width t) -(defsetf selected-window select-window) -(defsetf selected-screen select-screen) -(defsetf selected-frame select-frame) -(defsetf standard-case-table set-standard-case-table) -(defsetf syntax-table set-syntax-table) -(defsetf visited-file-modtime set-visited-file-modtime t) -(defsetf window-buffer set-window-buffer t) -(defsetf window-display-table set-window-display-table t) -(defsetf window-dedicated-p set-window-dedicated-p t) -(defsetf window-height () (store) +(cl-defsetf screen-height set-screen-height t) +(cl-defsetf screen-width set-screen-width t) +(cl-defsetf selected-window select-window) +(cl-defsetf selected-screen select-screen) +(cl-defsetf selected-frame select-frame) +(cl-defsetf standard-case-table set-standard-case-table) +(cl-defsetf syntax-table set-syntax-table) +(cl-defsetf visited-file-modtime set-visited-file-modtime t) +(cl-defsetf window-buffer set-window-buffer t) +(cl-defsetf window-display-table set-window-display-table t) +(cl-defsetf window-dedicated-p set-window-dedicated-p t) +(cl-defsetf window-height () (store) `(progn (enlarge-window (- ,store (window-height))) ,store)) -(defsetf window-hscroll set-window-hscroll) -(defsetf window-parameter set-window-parameter) -(defsetf window-point set-window-point) -(defsetf window-start set-window-start) -(defsetf window-width () (store) +(cl-defsetf window-hscroll set-window-hscroll) +(cl-defsetf window-parameter set-window-parameter) +(cl-defsetf window-point set-window-point) +(cl-defsetf window-start set-window-start) +(cl-defsetf window-width () (store) `(progn (enlarge-window (- ,store (window-width)) t) ,store)) -(defsetf x-get-secondary-selection x-own-secondary-selection t) -(defsetf x-get-selection x-own-selection t) +(cl-defsetf x-get-secondary-selection x-own-secondary-selection t) +(cl-defsetf x-get-selection x-own-selection t) -;; This is a hack that allows (setf (eq a 7) B) to mean either +;; This is a hack that allows (cl-setf (eq a 7) B) to mean either ;; (setq a 7) or (setq a nil) depending on whether B is nil or not. ;; This is useful when you have control over the PLACE but not over ;; the VALUE, as is the case in define-minor-mode's :variable. -(define-setf-method eq (place val) - (let ((method (get-setf-method place cl-macro-environment)) +(cl-define-setf-method eq (place val) + (let ((method (cl-get-setf-method place cl-macro-environment)) (val-temp (make-symbol "--eq-val--")) (store-temp (make-symbol "--eq-store--"))) (list (append (nth 0 method) (list val-temp)) @@ -2158,12 +2160,12 @@ Example: ;; available while compiling cl-macs, we fake it by referring to the global ;; variable cl-macro-environment directly. -(define-setf-method apply (func arg1 &rest rest) - (or (and (memq (car-safe func) '(quote function function*)) +(cl-define-setf-method apply (func arg1 &rest rest) + (or (and (memq (car-safe func) '(quote function cl-function)) (symbolp (car-safe (cdr-safe func)))) - (error "First arg to apply in setf is not (function SYM): %s" func)) + (error "First arg to apply in cl-setf is not (function SYM): %s" func)) (let* ((form (cons (nth 1 func) (cons arg1 rest))) - (method (get-setf-method form cl-macro-environment))) + (method (cl-get-setf-method form cl-macro-environment))) (list (car method) (nth 1 method) (nth 2 method) (cl-setf-make-apply (nth 3 method) (cadr func) (car method)) (cl-setf-make-apply (nth 4 method) (cadr func) (car method))))) @@ -2175,8 +2177,8 @@ Example: (error "%s is not suitable for use with setf-of-apply" func)) `(apply ',(car form) ,@(cdr form)))) -(define-setf-method nthcdr (n place) - (let ((method (get-setf-method place cl-macro-environment)) +(cl-define-setf-method nthcdr (n place) + (let ((method (cl-get-setf-method place cl-macro-environment)) (n-temp (make-symbol "--cl-nthcdr-n--")) (store-temp (make-symbol "--cl-nthcdr-store--"))) (list (cons n-temp (car method)) @@ -2188,8 +2190,8 @@ Example: ,(nth 3 method) ,store-temp) `(nthcdr ,n-temp ,(nth 4 method))))) -(define-setf-method getf (place tag &optional def) - (let ((method (get-setf-method place cl-macro-environment)) +(cl-define-setf-method cl-getf (place tag &optional def) + (let ((method (cl-get-setf-method place cl-macro-environment)) (tag-temp (make-symbol "--cl-getf-tag--")) (def-temp (make-symbol "--cl-getf-def--")) (store-temp (make-symbol "--cl-getf-store--"))) @@ -2199,10 +2201,10 @@ Example: `(let ((,(car (nth 2 method)) (cl-set-getf ,(nth 4 method) ,tag-temp ,store-temp))) ,(nth 3 method) ,store-temp) - `(getf ,(nth 4 method) ,tag-temp ,def-temp)))) + `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp)))) -(define-setf-method substring (place from &optional to) - (let ((method (get-setf-method place cl-macro-environment)) +(cl-define-setf-method substring (place from &optional to) + (let ((method (cl-get-setf-method place cl-macro-environment)) (from-temp (make-symbol "--cl-substring-from--")) (to-temp (make-symbol "--cl-substring-to--")) (store-temp (make-symbol "--cl-substring-store--"))) @@ -2217,10 +2219,10 @@ Example: ;;; Getting and optimizing setf-methods. ;;;###autoload -(defun get-setf-method (place &optional env) +(defun cl-get-setf-method (place &optional env) "Return a list of five values describing the setf-method for PLACE. PLACE may be any Lisp form which can appear as the PLACE argument to -a macro like `setf' or `incf'." +a macro like `cl-setf' or `cl-incf'." (if (symbolp place) (let ((temp (make-symbol "--cl-setf--"))) (list nil nil (list temp) `(setq ,place ,temp) place)) @@ -2237,20 +2239,20 @@ a macro like `setf' or `incf'." (error "Setf-method for %s returns malformed method" func))) (and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name) - (get-setf-method (compiler-macroexpand place))) + (cl-get-setf-method (cl-compiler-macroexpand place))) (and (eq func 'edebug-after) - (get-setf-method (nth (1- (length place)) place) + (cl-get-setf-method (nth (1- (length place)) place) env))))) (if (eq place (setq place (macroexpand place env))) (if (and (symbolp (car place)) (fboundp (car place)) (symbolp (symbol-function (car place)))) - (get-setf-method (cons (symbol-function (car place)) + (cl-get-setf-method (cons (symbol-function (car place)) (cdr place)) env) (error "No setf-method known for %s" (car place))) - (get-setf-method place env))))) + (cl-get-setf-method place env))))) (defun cl-setf-do-modify (place opt-expr) - (let* ((method (get-setf-method place cl-macro-environment)) + (let* ((method (cl-get-setf-method place cl-macro-environment)) (temps (car method)) (values (nth 1 method)) (lets nil) (subs nil) (optimize (and (not (eq opt-expr 'no-opt)) @@ -2264,8 +2266,8 @@ a macro like `setf' or `incf'." (push (cons (pop temps) (pop values)) subs) (push (list (pop temps) (pop values)) lets))) (list (nreverse lets) - (cons (car (nth 2 method)) (sublis subs (nth 3 method))) - (sublis subs (nth 4 method))))) + (cons (car (nth 2 method)) (cl-sublis subs (nth 3 method))) + (cl-sublis subs (nth 4 method))))) (defun cl-setf-do-store (spec val) (let ((sym (car spec)) @@ -2273,7 +2275,7 @@ a macro like `setf' or `incf'." (if (or (cl-const-expr-p val) (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) (cl-setf-simple-store-p sym form)) - (subst val sym form) + (cl-subst val sym form) `(let ((,sym ,val)) ,form)))) (defun cl-setf-simple-store-p (sym form) @@ -2284,18 +2286,18 @@ a macro like `setf' or `incf'." ;;; The standard modify macros. ;;;###autoload -(defmacro setf (&rest args) +(defmacro cl-setf (&rest args) "Set each PLACE to the value of its VAL. This is a generalized version of `setq'; the PLACEs may be symbolic references such as (car x) or (aref x i), as well as plain symbols. -For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y). +For example, (cl-setf (cl-cadar x) y) is equivalent to (setcar (cdar x) y). The return value is the last VAL in the list. \(fn PLACE VAL PLACE VAL ...)" (declare (debug (&rest [place form]))) (if (cdr (cdr args)) (let ((sets nil)) - (while args (push `(setf ,(pop args) ,(pop args)) sets)) + (while args (push `(cl-setf ,(pop args) ,(pop args)) sets)) (cons 'progn (nreverse sets))) (if (symbolp (car args)) (and args (cons 'setq args)) @@ -2304,13 +2306,13 @@ The return value is the last VAL in the list. (if (car method) `(let* ,(car method) ,store) store))))) ;;;###autoload -(defmacro psetf (&rest args) +(defmacro cl-psetf (&rest args) "Set PLACEs to the values VALs in parallel. -This is like `setf', except that all VAL forms are evaluated (in order) +This is like `cl-setf', except that all VAL forms are evaluated (in order) before assigning any PLACEs to the corresponding values. \(fn PLACE VAL PLACE VAL ...)" - (declare (debug setf)) + (declare (debug cl-setf)) (let ((p args) (simple t) (vars nil)) (while p (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) @@ -2318,20 +2320,20 @@ before assigning any PLACEs to the corresponding values. (if (memq (car p) vars) (error "Destination duplicated in psetf: %s" (car p))) (push (pop p) vars) - (or p (error "Odd number of arguments to psetf")) + (or p (error "Odd number of arguments to cl-psetf")) (pop p)) (if simple - `(progn (setf ,@args) nil) + `(progn (cl-setf ,@args) nil) (setq args (reverse args)) - (let ((expr `(setf ,(cadr args) ,(car args)))) + (let ((expr `(cl-setf ,(cadr args) ,(car args)))) (while (setq args (cddr args)) - (setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr)))) + (setq expr `(cl-setf ,(cadr args) (prog1 ,(car args) ,expr)))) `(progn ,expr nil))))) ;;;###autoload (defun cl-do-pop (place) (if (cl-simple-expr-p place) - `(prog1 (car ,place) (setf ,place (cdr ,place))) + `(prog1 (car ,place) (cl-setf ,place (cdr ,place))) (let* ((method (cl-setf-do-modify place t)) (temp (make-symbol "--cl-pop--"))) `(let* (,@(car method) @@ -2340,9 +2342,9 @@ before assigning any PLACEs to the corresponding values. ,(cl-setf-do-store (nth 1 method) `(cdr ,temp))))))) ;;;###autoload -(defmacro remf (place tag) +(defmacro cl-remf (place tag) "Remove TAG from property list PLACE. -PLACE may be a symbol, or any generalized variable allowed by `setf'. +PLACE may be a symbol, or any generalized variable allowed by `cl-setf'. The form returns true if TAG was found and removed, nil otherwise." (declare (debug (place form))) (let* ((method (cl-setf-do-modify place t)) @@ -2360,27 +2362,27 @@ The form returns true if TAG was found and removed, nil otherwise." `(cl-do-remf ,tval ,ttag))))) ;;;###autoload -(defmacro shiftf (place &rest args) +(defmacro cl-shiftf (place &rest args) "Shift left among PLACEs. -Example: (shiftf A B C) sets A to B, B to C, and returns the old A. -Each PLACE may be a symbol, or any generalized variable allowed by `setf'. +Example: (cl-shiftf A B C) sets A to B, B to C, and returns the old A. +Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'. \(fn PLACE... VAL)" (declare (debug (&rest place))) (cond ((null args) place) - ((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args)))) + ((symbolp place) `(prog1 ,place (setq ,place (cl-shiftf ,@args)))) (t (let ((method (cl-setf-do-modify place 'unsafe))) `(let* ,(car method) (prog1 ,(nth 2 method) - ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args)))))))) + ,(cl-setf-do-store (nth 1 method) `(cl-shiftf ,@args)))))))) ;;;###autoload -(defmacro rotatef (&rest args) +(defmacro cl-rotatef (&rest args) "Rotate left among PLACEs. -Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. -Each PLACE may be a symbol, or any generalized variable allowed by `setf'. +Example: (cl-rotatef A B C) sets A to B, B to C, and C to A. It returns nil. +Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'. \(fn PLACE...)" (declare (debug (&rest place))) @@ -2390,7 +2392,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (first (car args))) (while (cdr args) (setq sets (nconc sets (list (pop args) (car args))))) - `(psetf ,@sets ,(car args) ,first))) + `(cl-psetf ,@sets ,(car args) ,first))) (let* ((places (reverse args)) (temp (make-symbol "--cl-rotatef--")) (form temp)) @@ -2404,10 +2406,10 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. ,(cl-setf-do-store (nth 1 method) form) nil))))) ;;;###autoload -(defmacro letf (bindings &rest body) +(defmacro cl-letf (bindings &rest body) "Temporarily bind to PLACEs. This is the analogue of `let', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding VALUE, then the BODY forms are executed. On exit, either normally or because of a `throw' or error, the PLACEs are set back to their original values. Note that this macro is *not* available in Common Lisp. @@ -2424,7 +2426,7 @@ the PLACE is not modified before executing BODY. (let* ((place (if (symbolp (caar rev)) `(symbol-value ',(caar rev)) (caar rev))) - (value (cadar rev)) + (value (cl-cadar rev)) (method (cl-setf-do-modify place 'no-opt)) (save (make-symbol "--cl-letf-save--")) (bound (and (memq (car place) '(symbol-value symbol-function)) @@ -2463,10 +2465,10 @@ the PLACE is not modified before executing BODY. ;;;###autoload -(defmacro letf* (bindings &rest body) +(defmacro cl-letf* (bindings &rest body) "Temporarily bind to PLACEs. This is the analogue of `let*', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding VALUE, then the BODY forms are executed. On exit, either normally or because of a `throw' or error, the PLACEs are set back to their original values. Note that this macro is *not* available in Common Lisp. @@ -2474,22 +2476,22 @@ As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY. \(fn ((PLACE VALUE) ...) BODY...)" - (declare (indent 1) (debug letf)) + (declare (indent 1) (debug cl-letf)) (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings - (setq body (list `(letf (,(pop bindings)) ,@body)))) + (setq body (list `(cl-letf (,(pop bindings)) ,@body)))) (car body))) ;;;###autoload -(defmacro callf (func place &rest args) +(defmacro cl-callf (func place &rest args) "Set PLACE to (FUNC PLACE ARGS...). FUNC should be an unquoted function name. PLACE may be a symbol, -or any generalized variable allowed by `setf'. +or any generalized variable allowed by `cl-setf'. \(fn FUNC PLACE ARGS...)" - (declare (indent 2) (debug (function* place &rest form))) + (declare (indent 2) (debug (cl-function place &rest form))) (let* ((method (cl-setf-do-modify place (cons 'list args))) (rargs (cons (nth 2 method) args))) `(let* ,(car method) @@ -2498,48 +2500,48 @@ or any generalized variable allowed by `setf'. `(funcall #',func ,@rargs)))))) ;;;###autoload -(defmacro callf2 (func arg1 place &rest args) +(defmacro cl-callf2 (func arg1 place &rest args) "Set PLACE to (FUNC ARG1 PLACE ARGS...). -Like `callf', but PLACE is the second argument of FUNC, not the first. +Like `cl-callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" - (declare (indent 3) (debug (function* form place &rest form))) + (declare (indent 3) (debug (cl-function form place &rest form))) (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) - `(setf ,place (,func ,arg1 ,place ,@args)) + `(cl-setf ,place (,func ,arg1 ,place ,@args)) (let* ((method (cl-setf-do-modify place (cons 'list args))) (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--"))) - (rargs (list* (or temp arg1) (nth 2 method) args))) + (rargs (cl-list* (or temp arg1) (nth 2 method) args))) `(let* (,@(and temp (list (list temp arg1))) ,@(car method)) ,(cl-setf-do-store (nth 1 method) (if (symbolp func) (cons func rargs) `(funcall #',func ,@rargs))))))) ;;;###autoload -(defmacro define-modify-macro (name arglist func &optional doc) - "Define a `setf'-like modify macro. +(defmacro cl-define-modify-macro (name arglist func &optional doc) + "Define a `cl-setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other arguments -from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" +from ARGLIST using FUNC: (cl-define-modify-macro cl-incf (&optional (n 1)) +)" (declare (debug (&define name cl-lambda-list ;; should exclude &key symbolp &optional stringp))) - (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) + (if (memq '&key arglist) (error "&key not allowed in cl-define-modify-macro")) (let ((place (make-symbol "--cl-place--"))) - `(defmacro* ,name (,place ,@arglist) + `(cl-defmacro ,name (,place ,@arglist) ,doc - (,(if (memq '&rest arglist) #'list* #'list) - #'callf ',func ,place + (,(if (memq '&rest arglist) #'cl-list* #'list) + #'cl-callf ',func ,place ,@(cl-arglist-args arglist))))) ;;; Structures. ;;;###autoload -(defmacro defstruct (struct &rest descs) +(defmacro cl-defstruct (struct &rest descs) "Define a struct type. This macro defines a new data type called NAME that stores data in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME' copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'. -You can use the accessors to set the corresponding slots, via `setf'. +You can use the accessors to set the corresponding slots, via `cl-setf'. NAME may instead take the form (NAME OPTIONS...), where each OPTION is either a single keyword or (KEYWORD VALUE). @@ -2548,7 +2550,7 @@ See Info node `(cl)Structures' for a list of valid keywords. Each SLOT may instead take the form (SLOT SLOT-OPTS...), where SLOT-OPTS are keyword-value pairs for that slot. Currently, only one keyword is supported, `:read-only'. If this has a non-nil -value, that slot cannot be set via `setf'. +value, that slot cannot be set via `cl-setf'. \(fn NAME SLOTS...)" (declare (doc-string 2) @@ -2660,7 +2662,7 @@ value, that slot cannot be set via `setf'. (if (cadr inc-type) (setq tag name named t)) (let ((incl include)) (while incl - (push `(pushnew ',tag + (push `(cl-pushnew ',tag ,(intern (format "cl-struct-%s-tags" incl))) forms) (setq incl (get incl 'cl-struct-include))))) @@ -2685,9 +2687,9 @@ value, that slot cannot be set via `setf'. `(and (consp cl-x) (memq (nth ,pos cl-x) ,tag-symbol)))))) pred-check (and pred-form (> safety 0) - (if (and (eq (caadr pred-form) 'vectorp) + (if (and (eq (cl-caadr pred-form) 'vectorp) (= safety 1)) - (cons 'and (cdddr pred-form)) pred-form))) + (cons 'and (cl-cdddr pred-form)) pred-form))) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -2702,8 +2704,8 @@ value, that slot cannot be set via `setf'. (let ((accessor (intern (format "%s%s" conc-name slot)))) (push slot slots) (push (nth 1 desc) defaults) - (push (list* - 'defsubst* accessor '(cl-x) + (push (cl-list* + 'cl-defsubst accessor '(cl-x) (append (and pred-check (list `(or ,pred-check @@ -2713,7 +2715,7 @@ value, that slot cannot be set via `setf'. (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))))) forms) (push (cons accessor t) side-eff) - (push `(define-setf-method ,accessor (cl-x) + (push `(cl-define-setf-method ,accessor (cl-x) ,(if (cadr (memq :read-only (cddr desc))) `(progn (ignore cl-x) (error "%s is a read-only slot" @@ -2739,7 +2741,7 @@ value, that slot cannot be set via `setf'. (setq slots (nreverse slots) defaults (nreverse defaults)) (and predicate pred-form - (progn (push `(defsubst* ,predicate (cl-x) + (progn (push `(cl-defsubst ,predicate (cl-x) ,(if (eq (car pred-form) 'and) (append pred-form '(t)) `(and ,pred-form t))) forms) @@ -2755,12 +2757,12 @@ value, that slot cannot be set via `setf'. (let* ((name (caar constrs)) (args (cadr (pop constrs))) (anames (cl-arglist-args args)) - (make (mapcar* (function (lambda (s d) (if (memq s anames) s d))) + (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) - (push `(defsubst* ,name + (push `(cl-defsubst ,name (&cl-defs '(nil ,@descs) ,@args) (,type ,@make)) forms) - (if (cl-safe-expr-p `(progn ,@(mapcar #'second descs))) + (if (cl-safe-expr-p `(progn ,@(mapcar #'cl-second descs))) (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) (if print-func @@ -2769,10 +2771,10 @@ value, that slot cannot be set via `setf'. ;; the depth argument cl-n. (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n)) (and ,pred-form ,print-func)) - custom-print-functions) + cl-custom-print-functions) forms)) (push `(setq ,tag-symbol (list ',tag)) forms) - (push `(eval-when (compile load eval) + (push `(cl-eval-when (compile load eval) (put ',name 'cl-struct-slots ',descs) (put ',name 'cl-struct-type ',(list type (eq named t))) (put ',name 'cl-struct-include ',include) @@ -2789,7 +2791,7 @@ value, that slot cannot be set via `setf'. (list (list temp) (list x) (list store) `(progn ,@(and pred-form - (list `(or ,(subst temp 'cl-x pred-form) + (list `(or ,(cl-subst temp 'cl-x pred-form) (error ,(format "%s storing a non-%s" accessor name))))) @@ -2809,11 +2811,11 @@ value, that slot cannot be set via `setf'. ;;; Types and assertions. ;;;###autoload -(defmacro deftype (name arglist &rest body) +(defmacro cl-deftype (name arglist &rest body) "Define NAME as a new data type. -The type name can then be used in `typecase', `check-type', etc." - (declare (debug defmacro*) (doc-string 3)) - `(eval-when (compile load eval) +The type name can then be used in `cl-typecase', `cl-check-type', etc." + (declare (debug cl-defmacro) (doc-string 3)) + `(cl-eval-when (compile load eval) ,(cl-transform-function-property name 'cl-deftype-handler (cons `(&cl-defs '('*) ,@arglist) body)))) @@ -2824,10 +2826,10 @@ The type name can then be used in `typecase', `check-type', etc." ((memq type '(nil t)) type) ((eq type 'null) `(null ,val)) ((eq type 'atom) `(atom ,val)) - ((eq type 'float) `(floatp-safe ,val)) + ((eq type 'float) `(cl-floatp-safe ,val)) ((eq type 'real) `(numberp ,val)) ((eq type 'fixnum) `(integerp ,val)) - ;; FIXME: Should `character' accept things like ?\C-\M-a ? -stef + ;; FIXME: Should `character' accept things like ?\C-\M-a ? --Stef ((memq type '(character string-char)) `(characterp ,val)) (t (let* ((name (symbol-name type)) @@ -2840,28 +2842,28 @@ The type name can then be used in `typecase', `check-type', etc." ((memq (car type) '(integer float real number)) (delq t `(and ,(cl-make-type-test val (car type)) ,(if (memq (cadr type) '(* nil)) t - (if (consp (cadr type)) `(> ,val ,(caadr type)) + (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) `(>= ,val ,(cadr type)))) - ,(if (memq (caddr type) '(* nil)) t - (if (consp (caddr type)) `(< ,val ,(caaddr type)) - `(<= ,val ,(caddr type))))))) + ,(if (memq (cl-caddr type) '(* nil)) t + (if (consp (cl-caddr type)) `(< ,val ,(cl-caaddr type)) + `(<= ,val ,(cl-caddr type))))))) ((memq (car type) '(and or not)) (cons (car type) (mapcar (function (lambda (x) (cl-make-type-test val x))) (cdr type)))) - ((memq (car type) '(member member*)) - `(and (member* ,val ',(cdr type)) t)) + ((memq (car type) '(member cl-member)) + `(and (cl-member ,val ',(cdr type)) t)) ((eq (car type) 'satisfies) (list (cadr type) val)) (t (error "Bad type spec: %s" type))))) ;;;###autoload -(defun typep (object type) ; See compiler macro below. +(defun cl-typep (object type) ; See compiler macro below. "Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier." (eval (cl-make-type-test 'object type))) ;;;###autoload -(defmacro check-type (form type &optional string) +(defmacro cl-check-type (form type &optional string) "Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) @@ -2877,7 +2879,7 @@ STRING is an optional description of the desired type." `(let ((,temp ,form)) ,body nil))))) ;;;###autoload -(defmacro assert (form &optional show-args string &rest args) +(defmacro cl-assert (form &optional show-args string &rest args) "Verify that FORM returns non-nil; signal an error if not. Second arg SHOW-ARGS means to include arguments of FORM in message. Other args STRING and ARGS... are arguments to be passed to `error'. @@ -2903,7 +2905,7 @@ omitted, a default message listing FORM itself is used." ;;; Compiler macros. ;;;###autoload -(defmacro define-compiler-macro (func args &rest body) +(defmacro cl-define-compiler-macro (func args &rest body) "Define a compiler-only macro. This is like `defmacro', but macro expansion occurs only if the call to FUNC is compiled (i.e., not interpreted). Compiler macros should be used @@ -2914,11 +2916,11 @@ compiler macros are expanded repeatedly until no further expansions are possible. Unlike regular macros, BODY can decide to \"punt\" and leave the original function call alone by declaring an initial `&whole foo' parameter and then returning foo." - (declare (debug defmacro*)) + (declare (debug cl-defmacro)) (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) - `(eval-when (compile load eval) + `(cl-eval-when (compile load eval) ,(cl-transform-function-property func 'cl-compiler-macro (cons (if (memq '&whole args) (delq '&whole args) @@ -2937,7 +2939,7 @@ and then returning foo." (purecopy (file-name-nondirectory file))))))))) ;;;###autoload -(defun compiler-macroexpand (form) +(defun cl-compiler-macroexpand (form) (while (let ((func (car-safe form)) (handler nil)) (while (and (symbolp func) @@ -2951,7 +2953,7 @@ and then returning foo." form) (defun cl-byte-compile-compiler-macro (form) - (if (eq form (setq form (compiler-macroexpand form))) + (if (eq form (setq form (cl-compiler-macroexpand form))) (byte-compile-normal-call form) (byte-compile-form form))) @@ -2959,7 +2961,7 @@ and then returning foo." (defvar cl-active-block-names nil) -(define-compiler-macro cl-block-wrapper (cl-form) +(cl-define-compiler-macro cl-block-wrapper (cl-form) (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) (cl-active-block-names (cons cl-entry cl-active-block-names)) (cl-body (macroexpand-all ;Performs compiler-macro expansions. @@ -2971,32 +2973,32 @@ and then returning foo." `(catch ,(nth 1 cl-form) ,@(cdr cl-body)) cl-body))) -(define-compiler-macro cl-block-throw (cl-tag cl-value) +(cl-define-compiler-macro cl-block-throw (cl-tag cl-value) (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names))) (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) ;;;###autoload -(defmacro defsubst* (name args &rest body) +(defmacro cl-defsubst (name args &rest body) "Define NAME as a function. Like `defun', except the function is automatically declared `inline', ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (block NAME ...). +surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" - (declare (debug defun*)) + (declare (debug cl-defun)) (let* ((argns (cl-arglist-args args)) (p argns) (pbody (cons 'progn body)) (unsafe (not (cl-safe-expr-p pbody)))) (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p)) `(progn ,(if p nil ; give up if defaults refer to earlier args - `(define-compiler-macro ,name + `(cl-define-compiler-macro ,name ,(if (memq '&key args) `(&whole cl-whole &cl-quote ,@args) (cons '&cl-quote args)) (cl-defsubst-expand - ',argns '(block ,name ,@body) + ',argns '(cl-block ,name ,@body) ;; We used to pass `simple' as ;; (not (or unsafe (cl-expr-access-order pbody argns))) ;; But this is much too simplistic since it @@ -3004,20 +3006,19 @@ surrounded by (block NAME ...). ;; cl-expr-access-order itself is also too naive). nil ,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns))) - (defun* ,name ,args ,@body)))) + (cl-defun ,name ,args ,@body)))) (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole (if (cl-simple-exprs-p argvs) (setq simple t)) (let* ((substs ()) (lets (delq nil - (mapcar* (function - (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (push (cons argn argv) substs) - (and unsafe (list argn argv))) - (list argn argv)))) - argns argvs)))) + (cl-mapcar (lambda (argn argv) + (if (or simple (cl-const-expr-p argv)) + (progn (push (cons argn argv) substs) + (and unsafe (list argn argv))) + (list argn argv))) + argns argvs)))) ;; FIXME: `sublis/subst' will happily substitute the symbol ;; `argn' in places where it's not used as a reference ;; to a variable. @@ -3025,8 +3026,8 @@ surrounded by (block NAME ...). ;; scope, leading to name capture. (setq body (cond ((null substs) body) ((null (cdr substs)) - (subst (cdar substs) (caar substs) body)) - (t (sublis substs body)))) + (cl-subst (cdar substs) (caar substs) body)) + (t (cl-sublis substs body)))) (if lets `(let ,lets ,body) body)))) @@ -3035,7 +3036,7 @@ surrounded by (block NAME ...). ;; mainly to make sure these macros will be present. (put 'eql 'byte-compile nil) -(define-compiler-macro eql (&whole form a b) +(cl-define-compiler-macro eql (&whole form a b) (cond ((eq (cl-const-expr-p a) t) (let ((val (cl-const-expr-val a))) (if (and (numberp val) (not (integerp val))) @@ -3057,7 +3058,7 @@ surrounded by (block NAME ...). (eq ,a ,b))) (t form))) -(define-compiler-macro member* (&whole form a list &rest keys) +(cl-define-compiler-macro cl-member (&whole form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) (cl-const-expr-val (nth 1 keys))))) (cond ((eq test 'eq) `(memq ,a ,list)) @@ -3065,41 +3066,41 @@ surrounded by (block NAME ...). ((or (null keys) (eq test 'eql)) `(memql ,a ,list)) (t form)))) -(define-compiler-macro assoc* (&whole form a list &rest keys) +(cl-define-compiler-macro cl-assoc (&whole form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) (cl-const-expr-val (nth 1 keys))))) (cond ((eq test 'eq) `(assq ,a ,list)) ((eq test 'equal) `(assoc ,a ,list)) ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql))) - (if (floatp-safe (cl-const-expr-val a)) + (if (cl-floatp-safe (cl-const-expr-val a)) `(assoc ,a ,list) `(assq ,a ,list))) (t form)))) -(define-compiler-macro adjoin (&whole form a list &rest keys) +(cl-define-compiler-macro cl-adjoin (&whole form a list &rest keys) (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) (not (memq :key keys))) - `(if (member* ,a ,list ,@keys) ,list (cons ,a ,list)) + `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) form)) -(define-compiler-macro list* (arg &rest others) +(cl-define-compiler-macro cl-list* (arg &rest others) (let* ((args (reverse (cons arg others))) (form (car args))) (while (setq args (cdr args)) (setq form `(cons ,(car args) ,form))) form)) -(define-compiler-macro get* (sym prop &optional def) +(cl-define-compiler-macro cl-get (sym prop &optional def) (if def - `(getf (symbol-plist ,sym) ,prop ,def) + `(cl-getf (symbol-plist ,sym) ,prop ,def) `(get ,sym ,prop))) -(define-compiler-macro typep (&whole form val type) +(cl-define-compiler-macro cl-typep (&whole form val type) (if (cl-const-expr-p type) (let ((res (cl-make-type-test val (cl-const-expr-val type)))) (if (or (memq (cl-expr-contains res val) '(nil 1)) (cl-simple-expr-p val)) res (let ((temp (make-symbol "--cl-var--"))) - `(let ((,temp ,val)) ,(subst temp val res))))) + `(let ((,temp ,val)) ,(cl-subst temp val res))))) form)) @@ -3110,35 +3111,35 @@ surrounded by (block NAME ...). `(lambda (w x) ,(if (symbolp (cadr y)) `(list ',(cadr y) - (list ',(caddr y) x)) + (list ',(cl-caddr y) x)) (cons 'list (cdr y)))))) - '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) - (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) - (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) - (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) - (caaar car caar) (caadr car cadr) (cadar car cdar) - (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) - (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) - (caaadr car caadr) (caadar car cadar) (caaddr car caddr) - (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) - (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) - (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) - (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) + '((cl-first 'car x) (cl-second 'cadr x) (cl-third 'cl-caddr x) (cl-fourth 'cl-cadddr x) + (cl-fifth 'nth 4 x) (cl-sixth 'nth 5 x) (cl-seventh 'nth 6 x) + (cl-eighth 'nth 7 x) (cl-ninth 'nth 8 x) (cl-tenth 'nth 9 x) + (cl-rest 'cdr x) (cl-endp 'null x) (cl-plusp '> x 0) (cl-minusp '< x 0) + (cl-caaar car caar) (cl-caadr car cadr) (cl-cadar car cdar) + (cl-caddr car cddr) (cl-cdaar cdr caar) (cl-cdadr cdr cadr) + (cl-cddar cdr cdar) (cl-cdddr cdr cddr) (cl-caaaar car cl-caaar) + (cl-caaadr car cl-caadr) (cl-caadar car cl-cadar) (cl-caaddr car cl-caddr) + (cl-cadaar car cl-cdaar) (cl-cadadr car cl-cdadr) (cl-caddar car cl-cddar) + (cl-cadddr car cl-cdddr) (cl-cdaaar cdr cl-caaar) (cl-cdaadr cdr cl-caadr) + (cl-cdadar cdr cl-cadar) (cl-cdaddr cdr cl-caddr) (cl-cddaar cdr cl-cdaar) + (cl-cddadr cdr cl-cdadr) (cl-cdddar cdr cl-cddar) (cl-cddddr cdr cl-cdddr) )) ;;; Things that are inline. -(proclaim '(inline floatp-safe acons map concatenate notany notevery - cl-set-elt revappend nreconc gethash)) +(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery + cl-set-elt cl-revappend cl-nreconc gethash)) ;;; Things that are side-effect-free. (mapc (lambda (x) (put x 'side-effect-free t)) - '(oddp evenp signum last butlast ldiff pairlis gcd lcm - isqrt floor* ceiling* truncate* round* mod* rem* subseq - list-length get* getf)) + '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd cl-lcm + cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq + cl-list-length cl-get cl-getf)) ;;; Things that are side-effect-and-error-free. (mapc (lambda (x) (put x 'side-effect-free 'error-free)) - '(eql floatp-safe list* subst acons equalp random-state-p - copy-tree sublis)) + '(eql cl-floatp-safe cl-list* cl-subst cl-acons cl-equalp cl-random-state-p + copy-tree cl-sublis)) (run-hooks 'cl-macs-load-hook) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 233f0c83a6e..1db2f19349b 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -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 diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 137dd1bfb84..3b83a713402 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -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 -;; Version: 2.02 +;; Author: Stefan Monnier ;; 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.") +(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 "\\_"))) +;; (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)))))) -(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. - -(provide 'cl) - -(run-hooks 'cl-load-hook) - -;; Local variables: -;; byte-compile-dynamic: t -;; byte-compile-warnings: (not cl-functions) -;; End: - ;;; cl.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index ba8f9c4c148..be51b5c3dd3 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -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)))) -- 2.39.2