Provide generalized variables in core Elisp.
[bpt/emacs.git] / lisp / emacs-lisp / cl-lib.el
CommitLineData
bb3faf5b 1;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*-
7c1898a7
SM
2
3;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
4
5;; Author: Dave Gillespie <daveg@synaptics.com>
6;; Version: 2.02
7;; Keywords: extensions
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; These are extensions to Emacs Lisp that provide a degree of
27;; Common Lisp compatibility, beyond what is already built-in
28;; in Emacs Lisp.
29;;
30;; This package was written by Dave Gillespie; it is a complete
31;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
32;;
33;; Bug reports, comments, and suggestions are welcome!
34
35;; This file contains the portions of the Common Lisp extensions
36;; package which should always be present.
37
38
39;;; Future notes:
40
41;; Once Emacs 19 becomes standard, many things in this package which are
42;; messy for reasons of compatibility can be greatly simplified. For now,
43;; I prefer to maintain one unified version.
44
45
46;;; Change Log:
47
48;; Version 2.02 (30 Jul 93):
49;; * Added "cl-compat.el" file, extra compatibility with old package.
50;; * Added `lexical-let' and `lexical-let*'.
51;; * Added `define-modify-macro', `callf', and `callf2'.
52;; * Added `ignore-errors'.
53;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero.
54;; * Merged `*gentemp-counter*' into `*gensym-counter*'.
55;; * Extended `subseq' to allow negative START and END like `substring'.
56;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses.
57;; * Added `concat', `vconcat' loop clauses.
58;; * Cleaned up a number of compiler warnings.
59
60;; Version 2.01 (7 Jul 93):
61;; * Added support for FSF version of Emacs 19.
62;; * Added `add-hook' for Emacs 18 users.
63;; * Added `defsubst*' and `symbol-macrolet'.
64;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'.
65;; * Added `map', `concatenate', `reduce', `merge'.
66;; * Added `revappend', `nreconc', `tailp', `tree-equal'.
67;; * Added `assert', `check-type', `typecase', `typep', and `deftype'.
68;; * Added destructuring and `&environment' support to `defmacro*'.
69;; * Added destructuring to `loop', and added the following clauses:
70;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'.
71;; * Renamed `delete' to `delete*' and `remove' to `remove*'.
72;; * Completed support for all keywords in `remove*', `substitute', etc.
73;; * Added `most-positive-float' and company.
74;; * Fixed hash tables to work with latest Lucid Emacs.
75;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'.
76;; * Syntax for `warn' declarations has changed.
77;; * Improved implementation of `random*'.
78;; * Moved most sequence functions to a new file, cl-seq.el.
79;; * Moved `eval-when' into cl-macs.el.
80;; * Moved `pushnew' and `adjoin' to cl.el for most common cases.
81;; * Moved `provide' forms down to ends of files.
82;; * Changed expansion of `pop' to something that compiles to better code.
83;; * Changed so that no patch is required for Emacs 19 byte compiler.
84;; * Made more things dependent on `optimize' declarations.
85;; * Added a partial implementation of struct print functions.
86;; * Miscellaneous minor changes.
87
88;; Version 2.00:
89;; * First public release of this package.
90
91
92;;; Code:
93
94(defvar cl-optimize-speed 1)
95(defvar cl-optimize-safety 1)
96
57a7d507
SM
97;;;###autoload
98(define-obsolete-variable-alias
99 ;; This alias is needed for compatibility with .elc files that use defstruct
100 ;; and were compiled with Emacs<24.2.
101 'custom-print-functions 'cl-custom-print-functions "24.2")
7c1898a7
SM
102
103;;;###autoload
104(defvar cl-custom-print-functions nil
105 "This is a list of functions that format user objects for printing.
106Each function is called in turn with three arguments: the object, the
107stream, and the print level (currently ignored). If it is able to
108print the object it returns true; otherwise it returns nil and the
109printer proceeds to the next function on the list.
110
111This variable is not used at present, but it is defined in hopes that
112a future Emacs interpreter will be able to use it.")
113
114(defun cl-unload-function ()
115 "Stop unloading of the Common Lisp extensions."
116 (message "Cannot unload the feature `cl'")
bb3faf5b 117 ;; Stop standard unloading!
7c1898a7
SM
118 t)
119
120;;; Generalized variables.
121;; These macros are defined here so that they
122;; can safely be used in .emacs files.
123
124(defmacro cl-incf (place &optional x)
125 "Increment PLACE by X (1 by default).
2ee3d7f0 126PLACE may be a symbol, or any generalized variable allowed by `setf'.
7c1898a7
SM
127The return value is the incremented value of PLACE."
128 (declare (debug (place &optional form)))
129 (if (symbolp place)
130 (list 'setq place (if x (list '+ place x) (list '1+ place)))
131 (list 'cl-callf '+ place (or x 1))))
132
133(defmacro cl-decf (place &optional x)
134 "Decrement PLACE by X (1 by default).
2ee3d7f0 135PLACE may be a symbol, or any generalized variable allowed by `setf'.
7c1898a7
SM
136The return value is the decremented value of PLACE."
137 (declare (debug cl-incf))
138 (if (symbolp place)
139 (list 'setq place (if x (list '- place x) (list '1- place)))
140 (list 'cl-callf '- place (or x 1))))
141
7c1898a7
SM
142(defmacro cl-pushnew (x place &rest keys)
143 "(cl-pushnew X PLACE): insert X at the head of the list if not already there.
2ee3d7f0 144Like (push X PLACE), except that the list is unmodified if X is `eql' to
7c1898a7
SM
145an element already on the list.
146\nKeywords supported: :test :test-not :key
147\n(fn X PLACE [KEYWORD VALUE]...)"
148 (declare (debug
149 (form place &rest
150 &or [[&or ":test" ":test-not" ":key"] function-form]
151 [keywordp form])))
152 (if (symbolp place)
153 (if (null keys)
154 `(let ((x ,x))
155 (if (memql x ,place)
156 ;; This symbol may later on expand to actual code which then
157 ;; trigger warnings like "value unused" since cl-pushnew's return
158 ;; value is rarely used. It should not matter that other
159 ;; warnings may be silenced, since `place' is used earlier and
160 ;; should have triggered them already.
161 (with-no-warnings ,place)
162 (setq ,place (cons x ,place))))
163 (list 'setq place (cl-list* 'cl-adjoin x place keys)))
164 (cl-list* 'cl-callf2 'cl-adjoin x place keys)))
165
bb3faf5b 166(defun cl--set-elt (seq n val)
7c1898a7
SM
167 (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
168
bb3faf5b 169(defun cl--set-buffer-substring (start end val)
7c1898a7
SM
170 (save-excursion (delete-region start end)
171 (goto-char start)
172 (insert val)
173 val))
174
bb3faf5b 175(defun cl--set-substring (str start end val)
7c1898a7
SM
176 (if end (if (< end 0) (cl-incf end (length str)))
177 (setq end (length str)))
178 (if (< start 0) (cl-incf start (length str)))
179 (concat (and (> start 0) (substring str 0 start))
180 val
181 (and (< end (length str)) (substring str end))))
182
183
7c1898a7
SM
184;;; Blocks and exits.
185
bb3faf5b
SM
186(defalias 'cl--block-wrapper 'identity)
187(defalias 'cl--block-throw 'throw)
7c1898a7
SM
188
189
190;;; Multiple values.
191;; True multiple values are not supported, or even
192;; simulated. Instead, cl-multiple-value-bind and friends simply expect
193;; the target form to return the values as a list.
194
71adb94b
SM
195(defun cl--defalias (cl-f el-f &optional doc)
196 (defalias cl-f el-f doc)
197 (put cl-f 'byte-optimizer 'byte-compile-inline-expand))
198
199(cl--defalias 'cl-values #'list
7c1898a7
SM
200 "Return multiple values, Common Lisp style.
201The arguments of `cl-values' are the values
202that the containing function should return.
203
204\(fn &rest VALUES)")
205
71adb94b 206(cl--defalias 'cl-values-list #'identity
7c1898a7
SM
207 "Return multiple values, Common Lisp style, taken from a list.
208LIST specifies the list of values
209that the containing function should return.
210
211\(fn LIST)")
212
213(defsubst cl-multiple-value-list (expression)
214 "Return a list of the multiple values produced by EXPRESSION.
215This handles multiple values in Common Lisp style, but it does not
216work right when EXPRESSION calls an ordinary Emacs Lisp function
217that returns just one value."
218 expression)
219
220(defsubst cl-multiple-value-apply (function expression)
221 "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them.
222This handles multiple values in Common Lisp style, but it does not work
223right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
224one value."
225 (apply function expression))
226
227(defalias 'cl-multiple-value-call 'apply
228 "Apply FUNCTION to ARGUMENTS, taking multiple values into account.
229This implementation only handles the case where there is only one argument.")
230
231(defsubst cl-nth-value (n expression)
232 "Evaluate EXPRESSION to get multiple values and return the Nth one.
233This handles multiple values in Common Lisp style, but it does not work
234right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
235one value."
236 (nth n expression))
237
7c1898a7
SM
238;;; Declarations.
239
bb3faf5b
SM
240(defvar cl--compiling-file nil)
241(defun cl--compiling-file ()
242 (or cl--compiling-file
7c1898a7
SM
243 (and (boundp 'byte-compile--outbuffer)
244 (bufferp (symbol-value 'byte-compile--outbuffer))
245 (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
246 " *Compiler Output*"))))
247
248(defvar cl-proclaims-deferred nil)
249
250(defun cl-proclaim (spec)
251 (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
252 (push spec cl-proclaims-deferred))
253 nil)
254
255(defmacro cl-declaim (&rest specs)
256 (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x))))
257 specs)))
bb3faf5b 258 (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
7c1898a7
SM
259 (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when
260
261
262;;; Symbols.
263
264(defun cl-random-time ()
265 (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
266 (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
267 v))
268
269(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100))
270
271
272;;; Numbers.
273
274(defun cl-floatp-safe (object)
275 "Return t if OBJECT is a floating point number.
276On Emacs versions that lack floating-point support, this function
277always returns nil."
278 (and (numberp object) (not (integerp object))))
279
71adb94b 280(defsubst cl-plusp (number)
7c1898a7
SM
281 "Return t if NUMBER is positive."
282 (> number 0))
283
71adb94b 284(defsubst cl-minusp (number)
7c1898a7
SM
285 "Return t if NUMBER is negative."
286 (< number 0))
287
288(defun cl-oddp (integer)
289 "Return t if INTEGER is odd."
290 (eq (logand integer 1) 1))
291
292(defun cl-evenp (integer)
293 "Return t if INTEGER is even."
294 (eq (logand integer 1) 0))
295
296(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time)))
297
298(defconst cl-most-positive-float nil
299 "The largest value that a Lisp float can hold.
300If your system supports infinities, this is the largest finite value.
301For IEEE machines, this is approximately 1.79e+308.
302Call `cl-float-limits' to set this.")
303
304(defconst cl-most-negative-float nil
305 "The largest negative value that a Lisp float can hold.
306This is simply -`cl-most-positive-float'.
307Call `cl-float-limits' to set this.")
308
309(defconst cl-least-positive-float nil
310 "The smallest value greater than zero that a Lisp float can hold.
311For IEEE machines, it is about 4.94e-324 if denormals are supported,
312or 2.22e-308 if they are not.
313Call `cl-float-limits' to set this.")
314
315(defconst cl-least-negative-float nil
316 "The smallest value less than zero that a Lisp float can hold.
317This is simply -`cl-least-positive-float'.
318Call `cl-float-limits' to set this.")
319
320(defconst cl-least-positive-normalized-float nil
321 "The smallest normalized Lisp float greater than zero.
322This is the smallest value for which IEEE denormalization does not lose
323precision. For IEEE machines, this value is about 2.22e-308.
324For machines that do not support the concept of denormalization
325and gradual underflow, this constant equals `cl-least-positive-float'.
326Call `cl-float-limits' to set this.")
327
328(defconst cl-least-negative-normalized-float nil
329 "The smallest normalized Lisp float less than zero.
330This is simply -`cl-least-positive-normalized-float'.
331Call `cl-float-limits' to set this.")
332
333(defconst cl-float-epsilon nil
334 "The smallest positive float that adds to 1.0 to give a distinct value.
335Adding a number less than this to 1.0 returns 1.0 due to roundoff.
336For IEEE machines, epsilon is about 2.22e-16.
337Call `cl-float-limits' to set this.")
338
339(defconst cl-float-negative-epsilon nil
340 "The smallest positive float that subtracts from 1.0 to give a distinct value.
341For IEEE machines, it is about 1.11e-16.
342Call `cl-float-limits' to set this.")
343
344
345;;; Sequence functions.
346
71adb94b 347(cl--defalias 'cl-copy-seq 'copy-sequence)
7c1898a7 348
bb3faf5b 349(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs))
7c1898a7
SM
350
351(defun cl-mapcar (cl-func cl-x &rest cl-rest)
352 "Apply FUNCTION to each element of SEQ, and make a list of the results.
353If there are several SEQs, FUNCTION is called with that many arguments,
354and mapping stops as soon as the shortest list runs out. With just one
355SEQ, this is like `mapcar'. With several, it is like the Common Lisp
356`mapcar' function extended to arbitrary sequence types.
357\n(fn FUNCTION SEQ...)"
358 (if cl-rest
359 (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
bb3faf5b 360 (cl--mapcar-many cl-func (cons cl-x cl-rest))
7c1898a7
SM
361 (let ((cl-res nil) (cl-y (car cl-rest)))
362 (while (and cl-x cl-y)
363 (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
364 (nreverse cl-res)))
365 (mapcar cl-func cl-x)))
366
71adb94b 367(cl--defalias 'cl-svref 'aref)
7c1898a7
SM
368
369;;; List functions.
370
71adb94b
SM
371(cl--defalias 'cl-first 'car)
372(cl--defalias 'cl-second 'cadr)
373(cl--defalias 'cl-rest 'cdr)
374(cl--defalias 'cl-endp 'null)
7c1898a7 375
71adb94b
SM
376(cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.")
377(cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.")
7c1898a7 378
71adb94b
SM
379(defsubst cl-fifth (x)
380 "Return the fifth element of the list X."
7c1898a7
SM
381 (nth 4 x))
382
71adb94b
SM
383(defsubst cl-sixth (x)
384 "Return the sixth element of the list X."
7c1898a7
SM
385 (nth 5 x))
386
71adb94b
SM
387(defsubst cl-seventh (x)
388 "Return the seventh element of the list X."
7c1898a7
SM
389 (nth 6 x))
390
71adb94b
SM
391(defsubst cl-eighth (x)
392 "Return the eighth element of the list X."
7c1898a7
SM
393 (nth 7 x))
394
71adb94b
SM
395(defsubst cl-ninth (x)
396 "Return the ninth element of the list X."
7c1898a7
SM
397 (nth 8 x))
398
71adb94b
SM
399(defsubst cl-tenth (x)
400 "Return the tenth element of the list X."
7c1898a7
SM
401 (nth 9 x))
402
403(defun cl-caaar (x)
404 "Return the `car' of the `car' of the `car' of X."
71adb94b 405 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
406 (car (car (car x))))
407
408(defun cl-caadr (x)
409 "Return the `car' of the `car' of the `cdr' of X."
71adb94b 410 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
411 (car (car (cdr x))))
412
413(defun cl-cadar (x)
414 "Return the `car' of the `cdr' of the `car' of X."
71adb94b 415 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
416 (car (cdr (car x))))
417
418(defun cl-caddr (x)
419 "Return the `car' of the `cdr' of the `cdr' of X."
71adb94b 420 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
421 (car (cdr (cdr x))))
422
423(defun cl-cdaar (x)
424 "Return the `cdr' of the `car' of the `car' of X."
71adb94b 425 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
426 (cdr (car (car x))))
427
428(defun cl-cdadr (x)
429 "Return the `cdr' of the `car' of the `cdr' of X."
71adb94b 430 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
431 (cdr (car (cdr x))))
432
433(defun cl-cddar (x)
434 "Return the `cdr' of the `cdr' of the `car' of X."
71adb94b 435 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
436 (cdr (cdr (car x))))
437
438(defun cl-cdddr (x)
439 "Return the `cdr' of the `cdr' of the `cdr' of X."
71adb94b 440 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
441 (cdr (cdr (cdr x))))
442
443(defun cl-caaaar (x)
444 "Return the `car' of the `car' of the `car' of the `car' of X."
71adb94b 445 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
446 (car (car (car (car x)))))
447
448(defun cl-caaadr (x)
449 "Return the `car' of the `car' of the `car' of the `cdr' of X."
71adb94b 450 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
451 (car (car (car (cdr x)))))
452
453(defun cl-caadar (x)
454 "Return the `car' of the `car' of the `cdr' of the `car' of X."
71adb94b 455 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
456 (car (car (cdr (car x)))))
457
458(defun cl-caaddr (x)
459 "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
71adb94b 460 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
461 (car (car (cdr (cdr x)))))
462
463(defun cl-cadaar (x)
464 "Return the `car' of the `cdr' of the `car' of the `car' of X."
71adb94b 465 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
466 (car (cdr (car (car x)))))
467
468(defun cl-cadadr (x)
469 "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
71adb94b 470 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
471 (car (cdr (car (cdr x)))))
472
473(defun cl-caddar (x)
474 "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
71adb94b 475 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
476 (car (cdr (cdr (car x)))))
477
478(defun cl-cadddr (x)
479 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
71adb94b 480 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
481 (car (cdr (cdr (cdr x)))))
482
483(defun cl-cdaaar (x)
484 "Return the `cdr' of the `car' of the `car' of the `car' of X."
71adb94b 485 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
486 (cdr (car (car (car x)))))
487
488(defun cl-cdaadr (x)
489 "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
71adb94b 490 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
491 (cdr (car (car (cdr x)))))
492
493(defun cl-cdadar (x)
494 "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
71adb94b 495 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
496 (cdr (car (cdr (car x)))))
497
498(defun cl-cdaddr (x)
499 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
71adb94b 500 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
501 (cdr (car (cdr (cdr x)))))
502
503(defun cl-cddaar (x)
504 "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
71adb94b 505 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
506 (cdr (cdr (car (car x)))))
507
508(defun cl-cddadr (x)
509 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
71adb94b 510 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
511 (cdr (cdr (car (cdr x)))))
512
513(defun cl-cdddar (x)
514 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
71adb94b 515 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
516 (cdr (cdr (cdr (car x)))))
517
518(defun cl-cddddr (x)
519 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
71adb94b 520 (declare (compiler-macro cl--compiler-macro-cXXr))
7c1898a7
SM
521 (cdr (cdr (cdr (cdr x)))))
522
523;;(defun last* (x &optional n)
524;; "Returns the last link in the list LIST.
525;;With optional argument N, returns Nth-to-last link (default 1)."
526;; (if n
527;; (let ((m 0) (p x))
528;; (while (consp p) (cl-incf m) (pop p))
529;; (if (<= n 0) p
530;; (if (< n m) (nthcdr (- m n) x) x)))
531;; (while (consp (cdr x)) (pop x))
532;; x))
533
d9857e53 534(defun cl-list* (arg &rest rest)
7c1898a7
SM
535 "Return a new list with specified ARGs as elements, consed to last ARG.
536Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
537`(cons A (cons B (cons C D)))'.
538\n(fn ARG...)"
d9857e53 539 (declare (compiler-macro cl--compiler-macro-list*))
7c1898a7
SM
540 (cond ((not rest) arg)
541 ((not (cdr rest)) (cons arg (car rest)))
542 (t (let* ((n (length rest))
543 (copy (copy-sequence rest))
544 (last (nthcdr (- n 2) copy)))
545 (setcdr last (car (cdr last)))
546 (cons arg copy)))))
547
548(defun cl-ldiff (list sublist)
549 "Return a copy of LIST with the tail SUBLIST removed."
550 (let ((res nil))
551 (while (and (consp list) (not (eq list sublist)))
552 (push (pop list) res))
553 (nreverse res)))
554
555(defun cl-copy-list (list)
556 "Return a copy of LIST, which may be a dotted list.
557The elements of LIST are not copied, just the list structure itself."
558 (if (consp list)
559 (let ((res nil))
560 (while (consp list) (push (pop list) res))
561 (prog1 (nreverse res) (setcdr res list)))
562 (car list)))
563
7c1898a7
SM
564;; Autoloaded, but we have not loaded cl-loaddefs yet.
565(declare-function cl-floor "cl-extra" (x &optional y))
566(declare-function cl-ceiling "cl-extra" (x &optional y))
567(declare-function cl-truncate "cl-extra" (x &optional y))
568(declare-function cl-round "cl-extra" (x &optional y))
569(declare-function cl-mod "cl-extra" (x y))
570
d9857e53 571(defun cl-adjoin (cl-item cl-list &rest cl-keys)
7c1898a7
SM
572 "Return ITEM consed onto the front of LIST only if it's not already there.
573Otherwise, return LIST unmodified.
574\nKeywords supported: :test :test-not :key
575\n(fn ITEM LIST [KEYWORD VALUE]...)"
d9857e53 576 (declare (compiler-macro cl--compiler-macro-adjoin))
7c1898a7
SM
577 (cond ((or (equal cl-keys '(:test eq))
578 (and (null cl-keys) (not (numberp cl-item))))
579 (if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
580 ((or (equal cl-keys '(:test equal)) (null cl-keys))
581 (if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
582 (t (apply 'cl--adjoin cl-item cl-list cl-keys))))
583
584(defun cl-subst (cl-new cl-old cl-tree &rest cl-keys)
585 "Substitute NEW for OLD everywhere in TREE (non-destructively).
586Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
587\nKeywords supported: :test :test-not :key
588\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
589 (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
590 (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
bb3faf5b 591 (cl--do-subst cl-new cl-old cl-tree)))
7c1898a7 592
bb3faf5b 593(defun cl--do-subst (cl-new cl-old cl-tree)
7c1898a7
SM
594 (cond ((eq cl-tree cl-old) cl-new)
595 ((consp cl-tree)
bb3faf5b
SM
596 (let ((a (cl--do-subst cl-new cl-old (car cl-tree)))
597 (d (cl--do-subst cl-new cl-old (cdr cl-tree))))
7c1898a7
SM
598 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
599 cl-tree (cons a d))))
600 (t cl-tree)))
601
602(defun cl-acons (key value alist)
603 "Add KEY and VALUE to ALIST.
604Return a new list with (cons KEY VALUE) as car and ALIST as cdr."
605 (cons (cons key value) alist))
606
607(defun cl-pairlis (keys values &optional alist)
608 "Make an alist from KEYS and VALUES.
609Return a new alist composed by associating KEYS to corresponding VALUES;
610the process stops as soon as KEYS or VALUES run out.
611If ALIST is non-nil, the new pairs are prepended to it."
612 (nconc (cl-mapcar 'cons keys values) alist))
613
614
615;;; Miscellaneous.
616
617;;;###autoload
618(progn
f38ea36d
SM
619 ;; Make sure functions defined with cl-defsubst can be inlined even in
620 ;; packages which do not require CL.
621 (autoload 'cl--defsubst-expand "cl-macs")
7c1898a7
SM
622 ;; Autoload, so autoload.el and font-lock can use it even when CL
623 ;; is not loaded.
624 (put 'cl-defun 'doc-string-elt 3)
625 (put 'cl-defmacro 'doc-string-elt 3)
626 (put 'cl-defsubst 'doc-string-elt 3)
627 (put 'cl-defstruct 'doc-string-elt 2))
628
629(load "cl-loaddefs" nil 'quiet)
630
7c1898a7
SM
631(provide 'cl-lib)
632
633(run-hooks 'cl-load-hook)
634
635;; Local variables:
636;; byte-compile-dynamic: t
637;; byte-compile-warnings: (not cl-functions)
638;; End:
639
640;;; cl-lib.el ends here