Commit | Line | Data |
---|---|---|
7c1898a7 SM |
1 | ;;; cl-lib.el --- Common Lisp extensions for Emacs |
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. | |
106 | Each function is called in turn with three arguments: the object, the | |
107 | stream, and the print level (currently ignored). If it is able to | |
108 | print the object it returns true; otherwise it returns nil and the | |
109 | printer proceeds to the next function on the list. | |
110 | ||
111 | This variable is not used at present, but it is defined in hopes that | |
112 | a 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'") | |
117 | ;; stop standard unloading! | |
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). | |
126 | PLACE may be a symbol, or any generalized variable allowed by `cl-setf'. | |
127 | The 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). | |
135 | PLACE may be a symbol, or any generalized variable allowed by `cl-setf'. | |
136 | The 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 | ||
142 | ;; Autoloaded, but we haven't loaded cl-loaddefs yet. | |
143 | (declare-function cl-do-pop "cl-macs" (place)) | |
144 | ||
145 | (defmacro cl-pop (place) | |
146 | "Remove and return the head of the list stored in PLACE. | |
147 | Analogous to (prog1 (car PLACE) (cl-setf PLACE (cdr PLACE))), though more | |
148 | careful about evaluating each argument only once and in the right order. | |
149 | PLACE may be a symbol, or any generalized variable allowed by `cl-setf'." | |
150 | (declare (debug (place))) | |
151 | (if (symbolp place) | |
152 | (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) | |
153 | (cl-do-pop place))) | |
154 | ||
155 | (defmacro cl-push (x place) | |
156 | "Insert X at the head of the list stored in PLACE. | |
157 | Analogous to (cl-setf PLACE (cons X PLACE)), though more careful about | |
158 | evaluating each argument only once and in the right order. PLACE may | |
159 | be a symbol, or any generalized variable allowed by `cl-setf'." | |
160 | (declare (debug (form place))) | |
161 | (if (symbolp place) (list 'setq place (list 'cons x place)) | |
162 | (list 'cl-callf2 'cons x place))) | |
163 | ||
164 | (defmacro cl-pushnew (x place &rest keys) | |
165 | "(cl-pushnew X PLACE): insert X at the head of the list if not already there. | |
166 | Like (cl-push X PLACE), except that the list is unmodified if X is `eql' to | |
167 | an element already on the list. | |
168 | \nKeywords supported: :test :test-not :key | |
169 | \n(fn X PLACE [KEYWORD VALUE]...)" | |
170 | (declare (debug | |
171 | (form place &rest | |
172 | &or [[&or ":test" ":test-not" ":key"] function-form] | |
173 | [keywordp form]))) | |
174 | (if (symbolp place) | |
175 | (if (null keys) | |
176 | `(let ((x ,x)) | |
177 | (if (memql x ,place) | |
178 | ;; This symbol may later on expand to actual code which then | |
179 | ;; trigger warnings like "value unused" since cl-pushnew's return | |
180 | ;; value is rarely used. It should not matter that other | |
181 | ;; warnings may be silenced, since `place' is used earlier and | |
182 | ;; should have triggered them already. | |
183 | (with-no-warnings ,place) | |
184 | (setq ,place (cons x ,place)))) | |
185 | (list 'setq place (cl-list* 'cl-adjoin x place keys))) | |
186 | (cl-list* 'cl-callf2 'cl-adjoin x place keys))) | |
187 | ||
188 | (defun cl-set-elt (seq n val) | |
189 | (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) | |
190 | ||
191 | (defsubst cl-set-nthcdr (n list x) | |
192 | (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) | |
193 | ||
194 | (defun cl-set-buffer-substring (start end val) | |
195 | (save-excursion (delete-region start end) | |
196 | (goto-char start) | |
197 | (insert val) | |
198 | val)) | |
199 | ||
200 | (defun cl-set-substring (str start end val) | |
201 | (if end (if (< end 0) (cl-incf end (length str))) | |
202 | (setq end (length str))) | |
203 | (if (< start 0) (cl-incf start (length str))) | |
204 | (concat (and (> start 0) (substring str 0 start)) | |
205 | val | |
206 | (and (< end (length str)) (substring str end)))) | |
207 | ||
208 | ||
209 | ;;; Control structures. | |
210 | ||
211 | ;; These macros are so simple and so often-used that it's better to have | |
212 | ;; them all the time than to load them from cl-macs.el. | |
213 | ||
214 | (defun cl-map-extents (&rest cl-args) | |
215 | (apply 'cl-map-overlays cl-args)) | |
216 | ||
217 | ||
218 | ;;; Blocks and exits. | |
219 | ||
220 | (defalias 'cl-block-wrapper 'identity) | |
221 | (defalias 'cl-block-throw 'throw) | |
222 | ||
223 | ||
224 | ;;; Multiple values. | |
225 | ;; True multiple values are not supported, or even | |
226 | ;; simulated. Instead, cl-multiple-value-bind and friends simply expect | |
227 | ;; the target form to return the values as a list. | |
228 | ||
229 | (defalias 'cl-values #'list | |
230 | "Return multiple values, Common Lisp style. | |
231 | The arguments of `cl-values' are the values | |
232 | that the containing function should return. | |
233 | ||
234 | \(fn &rest VALUES)") | |
e364a2b7 | 235 | (put 'cl-values 'byte-optimizer 'byte-compile-inline-expand) |
7c1898a7 SM |
236 | |
237 | (defalias 'cl-values-list #'identity | |
238 | "Return multiple values, Common Lisp style, taken from a list. | |
239 | LIST specifies the list of values | |
240 | that the containing function should return. | |
241 | ||
242 | \(fn LIST)") | |
e364a2b7 | 243 | (put 'cl-values-list 'byte-optimizer 'byte-compile-inline-expand) |
7c1898a7 SM |
244 | |
245 | (defsubst cl-multiple-value-list (expression) | |
246 | "Return a list of the multiple values produced by EXPRESSION. | |
247 | This handles multiple values in Common Lisp style, but it does not | |
248 | work right when EXPRESSION calls an ordinary Emacs Lisp function | |
249 | that returns just one value." | |
250 | expression) | |
251 | ||
252 | (defsubst cl-multiple-value-apply (function expression) | |
253 | "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. | |
254 | This handles multiple values in Common Lisp style, but it does not work | |
255 | right when EXPRESSION calls an ordinary Emacs Lisp function that returns just | |
256 | one value." | |
257 | (apply function expression)) | |
258 | ||
259 | (defalias 'cl-multiple-value-call 'apply | |
260 | "Apply FUNCTION to ARGUMENTS, taking multiple values into account. | |
261 | This implementation only handles the case where there is only one argument.") | |
262 | ||
263 | (defsubst cl-nth-value (n expression) | |
264 | "Evaluate EXPRESSION to get multiple values and return the Nth one. | |
265 | This handles multiple values in Common Lisp style, but it does not work | |
266 | right when EXPRESSION calls an ordinary Emacs Lisp function that returns just | |
267 | one value." | |
268 | (nth n expression)) | |
269 | ||
7c1898a7 SM |
270 | ;;; Declarations. |
271 | ||
272 | (defvar cl-compiling-file nil) | |
273 | (defun cl-compiling-file () | |
274 | (or cl-compiling-file | |
275 | (and (boundp 'byte-compile--outbuffer) | |
276 | (bufferp (symbol-value 'byte-compile--outbuffer)) | |
277 | (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) | |
278 | " *Compiler Output*")))) | |
279 | ||
280 | (defvar cl-proclaims-deferred nil) | |
281 | ||
282 | (defun cl-proclaim (spec) | |
283 | (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) | |
284 | (push spec cl-proclaims-deferred)) | |
285 | nil) | |
286 | ||
287 | (defmacro cl-declaim (&rest specs) | |
288 | (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x)))) | |
289 | specs))) | |
290 | (if (cl-compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) | |
291 | (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when | |
292 | ||
293 | ||
294 | ;;; Symbols. | |
295 | ||
296 | (defun cl-random-time () | |
297 | (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) | |
298 | (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) | |
299 | v)) | |
300 | ||
301 | (defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100)) | |
302 | ||
303 | ||
304 | ;;; Numbers. | |
305 | ||
306 | (defun cl-floatp-safe (object) | |
307 | "Return t if OBJECT is a floating point number. | |
308 | On Emacs versions that lack floating-point support, this function | |
309 | always returns nil." | |
310 | (and (numberp object) (not (integerp object)))) | |
311 | ||
312 | (defun cl-plusp (number) | |
313 | "Return t if NUMBER is positive." | |
314 | (> number 0)) | |
315 | ||
316 | (defun cl-minusp (number) | |
317 | "Return t if NUMBER is negative." | |
318 | (< number 0)) | |
319 | ||
320 | (defun cl-oddp (integer) | |
321 | "Return t if INTEGER is odd." | |
322 | (eq (logand integer 1) 1)) | |
323 | ||
324 | (defun cl-evenp (integer) | |
325 | "Return t if INTEGER is even." | |
326 | (eq (logand integer 1) 0)) | |
327 | ||
328 | (defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time))) | |
329 | ||
330 | (defconst cl-most-positive-float nil | |
331 | "The largest value that a Lisp float can hold. | |
332 | If your system supports infinities, this is the largest finite value. | |
333 | For IEEE machines, this is approximately 1.79e+308. | |
334 | Call `cl-float-limits' to set this.") | |
335 | ||
336 | (defconst cl-most-negative-float nil | |
337 | "The largest negative value that a Lisp float can hold. | |
338 | This is simply -`cl-most-positive-float'. | |
339 | Call `cl-float-limits' to set this.") | |
340 | ||
341 | (defconst cl-least-positive-float nil | |
342 | "The smallest value greater than zero that a Lisp float can hold. | |
343 | For IEEE machines, it is about 4.94e-324 if denormals are supported, | |
344 | or 2.22e-308 if they are not. | |
345 | Call `cl-float-limits' to set this.") | |
346 | ||
347 | (defconst cl-least-negative-float nil | |
348 | "The smallest value less than zero that a Lisp float can hold. | |
349 | This is simply -`cl-least-positive-float'. | |
350 | Call `cl-float-limits' to set this.") | |
351 | ||
352 | (defconst cl-least-positive-normalized-float nil | |
353 | "The smallest normalized Lisp float greater than zero. | |
354 | This is the smallest value for which IEEE denormalization does not lose | |
355 | precision. For IEEE machines, this value is about 2.22e-308. | |
356 | For machines that do not support the concept of denormalization | |
357 | and gradual underflow, this constant equals `cl-least-positive-float'. | |
358 | Call `cl-float-limits' to set this.") | |
359 | ||
360 | (defconst cl-least-negative-normalized-float nil | |
361 | "The smallest normalized Lisp float less than zero. | |
362 | This is simply -`cl-least-positive-normalized-float'. | |
363 | Call `cl-float-limits' to set this.") | |
364 | ||
365 | (defconst cl-float-epsilon nil | |
366 | "The smallest positive float that adds to 1.0 to give a distinct value. | |
367 | Adding a number less than this to 1.0 returns 1.0 due to roundoff. | |
368 | For IEEE machines, epsilon is about 2.22e-16. | |
369 | Call `cl-float-limits' to set this.") | |
370 | ||
371 | (defconst cl-float-negative-epsilon nil | |
372 | "The smallest positive float that subtracts from 1.0 to give a distinct value. | |
373 | For IEEE machines, it is about 1.11e-16. | |
374 | Call `cl-float-limits' to set this.") | |
375 | ||
376 | ||
377 | ;;; Sequence functions. | |
378 | ||
379 | (defalias 'cl-copy-seq 'copy-sequence) | |
380 | ||
381 | (declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs)) | |
382 | ||
383 | (defun cl-mapcar (cl-func cl-x &rest cl-rest) | |
384 | "Apply FUNCTION to each element of SEQ, and make a list of the results. | |
385 | If there are several SEQs, FUNCTION is called with that many arguments, | |
386 | and mapping stops as soon as the shortest list runs out. With just one | |
387 | SEQ, this is like `mapcar'. With several, it is like the Common Lisp | |
388 | `mapcar' function extended to arbitrary sequence types. | |
389 | \n(fn FUNCTION SEQ...)" | |
390 | (if cl-rest | |
391 | (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) | |
392 | (cl-mapcar-many cl-func (cons cl-x cl-rest)) | |
393 | (let ((cl-res nil) (cl-y (car cl-rest))) | |
394 | (while (and cl-x cl-y) | |
395 | (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) | |
396 | (nreverse cl-res))) | |
397 | (mapcar cl-func cl-x))) | |
398 | ||
399 | (defalias 'cl-svref 'aref) | |
400 | ||
401 | ;;; List functions. | |
402 | ||
403 | (defalias 'cl-first 'car) | |
404 | (defalias 'cl-second 'cadr) | |
405 | (defalias 'cl-rest 'cdr) | |
406 | (defalias 'cl-endp 'null) | |
407 | ||
408 | (defun cl-third (x) | |
409 | "Return the cl-third element of the list X." | |
410 | (car (cdr (cdr x)))) | |
411 | ||
412 | (defun cl-fourth (x) | |
413 | "Return the cl-fourth element of the list X." | |
414 | (nth 3 x)) | |
415 | ||
416 | (defun cl-fifth (x) | |
417 | "Return the cl-fifth element of the list X." | |
418 | (nth 4 x)) | |
419 | ||
420 | (defun cl-sixth (x) | |
421 | "Return the cl-sixth element of the list X." | |
422 | (nth 5 x)) | |
423 | ||
424 | (defun cl-seventh (x) | |
425 | "Return the cl-seventh element of the list X." | |
426 | (nth 6 x)) | |
427 | ||
428 | (defun cl-eighth (x) | |
429 | "Return the cl-eighth element of the list X." | |
430 | (nth 7 x)) | |
431 | ||
432 | (defun cl-ninth (x) | |
433 | "Return the cl-ninth element of the list X." | |
434 | (nth 8 x)) | |
435 | ||
436 | (defun cl-tenth (x) | |
437 | "Return the cl-tenth element of the list X." | |
438 | (nth 9 x)) | |
439 | ||
440 | (defun cl-caaar (x) | |
441 | "Return the `car' of the `car' of the `car' of X." | |
442 | (car (car (car x)))) | |
443 | ||
444 | (defun cl-caadr (x) | |
445 | "Return the `car' of the `car' of the `cdr' of X." | |
446 | (car (car (cdr x)))) | |
447 | ||
448 | (defun cl-cadar (x) | |
449 | "Return the `car' of the `cdr' of the `car' of X." | |
450 | (car (cdr (car x)))) | |
451 | ||
452 | (defun cl-caddr (x) | |
453 | "Return the `car' of the `cdr' of the `cdr' of X." | |
454 | (car (cdr (cdr x)))) | |
455 | ||
456 | (defun cl-cdaar (x) | |
457 | "Return the `cdr' of the `car' of the `car' of X." | |
458 | (cdr (car (car x)))) | |
459 | ||
460 | (defun cl-cdadr (x) | |
461 | "Return the `cdr' of the `car' of the `cdr' of X." | |
462 | (cdr (car (cdr x)))) | |
463 | ||
464 | (defun cl-cddar (x) | |
465 | "Return the `cdr' of the `cdr' of the `car' of X." | |
466 | (cdr (cdr (car x)))) | |
467 | ||
468 | (defun cl-cdddr (x) | |
469 | "Return the `cdr' of the `cdr' of the `cdr' of X." | |
470 | (cdr (cdr (cdr x)))) | |
471 | ||
472 | (defun cl-caaaar (x) | |
473 | "Return the `car' of the `car' of the `car' of the `car' of X." | |
474 | (car (car (car (car x))))) | |
475 | ||
476 | (defun cl-caaadr (x) | |
477 | "Return the `car' of the `car' of the `car' of the `cdr' of X." | |
478 | (car (car (car (cdr x))))) | |
479 | ||
480 | (defun cl-caadar (x) | |
481 | "Return the `car' of the `car' of the `cdr' of the `car' of X." | |
482 | (car (car (cdr (car x))))) | |
483 | ||
484 | (defun cl-caaddr (x) | |
485 | "Return the `car' of the `car' of the `cdr' of the `cdr' of X." | |
486 | (car (car (cdr (cdr x))))) | |
487 | ||
488 | (defun cl-cadaar (x) | |
489 | "Return the `car' of the `cdr' of the `car' of the `car' of X." | |
490 | (car (cdr (car (car x))))) | |
491 | ||
492 | (defun cl-cadadr (x) | |
493 | "Return the `car' of the `cdr' of the `car' of the `cdr' of X." | |
494 | (car (cdr (car (cdr x))))) | |
495 | ||
496 | (defun cl-caddar (x) | |
497 | "Return the `car' of the `cdr' of the `cdr' of the `car' of X." | |
498 | (car (cdr (cdr (car x))))) | |
499 | ||
500 | (defun cl-cadddr (x) | |
501 | "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." | |
502 | (car (cdr (cdr (cdr x))))) | |
503 | ||
504 | (defun cl-cdaaar (x) | |
505 | "Return the `cdr' of the `car' of the `car' of the `car' of X." | |
506 | (cdr (car (car (car x))))) | |
507 | ||
508 | (defun cl-cdaadr (x) | |
509 | "Return the `cdr' of the `car' of the `car' of the `cdr' of X." | |
510 | (cdr (car (car (cdr x))))) | |
511 | ||
512 | (defun cl-cdadar (x) | |
513 | "Return the `cdr' of the `car' of the `cdr' of the `car' of X." | |
514 | (cdr (car (cdr (car x))))) | |
515 | ||
516 | (defun cl-cdaddr (x) | |
517 | "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." | |
518 | (cdr (car (cdr (cdr x))))) | |
519 | ||
520 | (defun cl-cddaar (x) | |
521 | "Return the `cdr' of the `cdr' of the `car' of the `car' of X." | |
522 | (cdr (cdr (car (car x))))) | |
523 | ||
524 | (defun cl-cddadr (x) | |
525 | "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." | |
526 | (cdr (cdr (car (cdr x))))) | |
527 | ||
528 | (defun cl-cdddar (x) | |
529 | "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." | |
530 | (cdr (cdr (cdr (car x))))) | |
531 | ||
532 | (defun cl-cddddr (x) | |
533 | "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." | |
534 | (cdr (cdr (cdr (cdr x))))) | |
535 | ||
536 | ;;(defun last* (x &optional n) | |
537 | ;; "Returns the last link in the list LIST. | |
538 | ;;With optional argument N, returns Nth-to-last link (default 1)." | |
539 | ;; (if n | |
540 | ;; (let ((m 0) (p x)) | |
541 | ;; (while (consp p) (cl-incf m) (pop p)) | |
542 | ;; (if (<= n 0) p | |
543 | ;; (if (< n m) (nthcdr (- m n) x) x))) | |
544 | ;; (while (consp (cdr x)) (pop x)) | |
545 | ;; x)) | |
546 | ||
d9857e53 | 547 | (defun cl-list* (arg &rest rest) |
7c1898a7 SM |
548 | "Return a new list with specified ARGs as elements, consed to last ARG. |
549 | Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to | |
550 | `(cons A (cons B (cons C D)))'. | |
551 | \n(fn ARG...)" | |
d9857e53 | 552 | (declare (compiler-macro cl--compiler-macro-list*)) |
7c1898a7 SM |
553 | (cond ((not rest) arg) |
554 | ((not (cdr rest)) (cons arg (car rest))) | |
555 | (t (let* ((n (length rest)) | |
556 | (copy (copy-sequence rest)) | |
557 | (last (nthcdr (- n 2) copy))) | |
558 | (setcdr last (car (cdr last))) | |
559 | (cons arg copy))))) | |
d9857e53 | 560 | (autoload 'cl--compiler-macro-list* "cl-macs") |
7c1898a7 SM |
561 | |
562 | (defun cl-ldiff (list sublist) | |
563 | "Return a copy of LIST with the tail SUBLIST removed." | |
564 | (let ((res nil)) | |
565 | (while (and (consp list) (not (eq list sublist))) | |
566 | (push (pop list) res)) | |
567 | (nreverse res))) | |
568 | ||
569 | (defun cl-copy-list (list) | |
570 | "Return a copy of LIST, which may be a dotted list. | |
571 | The elements of LIST are not copied, just the list structure itself." | |
572 | (if (consp list) | |
573 | (let ((res nil)) | |
574 | (while (consp list) (push (pop list) res)) | |
575 | (prog1 (nreverse res) (setcdr res list))) | |
576 | (car list))) | |
577 | ||
578 | (defun cl-maclisp-member (item list) | |
579 | (while (and list (not (equal item (car list)))) (setq list (cdr list))) | |
580 | list) | |
581 | ||
7c1898a7 SM |
582 | ;; Autoloaded, but we have not loaded cl-loaddefs yet. |
583 | (declare-function cl-floor "cl-extra" (x &optional y)) | |
584 | (declare-function cl-ceiling "cl-extra" (x &optional y)) | |
585 | (declare-function cl-truncate "cl-extra" (x &optional y)) | |
586 | (declare-function cl-round "cl-extra" (x &optional y)) | |
587 | (declare-function cl-mod "cl-extra" (x y)) | |
588 | ||
d9857e53 | 589 | (defun cl-adjoin (cl-item cl-list &rest cl-keys) |
7c1898a7 SM |
590 | "Return ITEM consed onto the front of LIST only if it's not already there. |
591 | Otherwise, return LIST unmodified. | |
592 | \nKeywords supported: :test :test-not :key | |
593 | \n(fn ITEM LIST [KEYWORD VALUE]...)" | |
d9857e53 | 594 | (declare (compiler-macro cl--compiler-macro-adjoin)) |
7c1898a7 SM |
595 | (cond ((or (equal cl-keys '(:test eq)) |
596 | (and (null cl-keys) (not (numberp cl-item)))) | |
597 | (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) | |
598 | ((or (equal cl-keys '(:test equal)) (null cl-keys)) | |
599 | (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) | |
600 | (t (apply 'cl--adjoin cl-item cl-list cl-keys)))) | |
d9857e53 | 601 | (autoload 'cl--compiler-macro-adjoin "cl-macs") |
7c1898a7 SM |
602 | |
603 | (defun cl-subst (cl-new cl-old cl-tree &rest cl-keys) | |
604 | "Substitute NEW for OLD everywhere in TREE (non-destructively). | |
605 | Return a copy of TREE with all elements `eql' to OLD replaced by NEW. | |
606 | \nKeywords supported: :test :test-not :key | |
607 | \n(fn NEW OLD TREE [KEYWORD VALUE]...)" | |
608 | (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) | |
609 | (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys) | |
610 | (cl-do-subst cl-new cl-old cl-tree))) | |
611 | ||
612 | (defun cl-do-subst (cl-new cl-old cl-tree) | |
613 | (cond ((eq cl-tree cl-old) cl-new) | |
614 | ((consp cl-tree) | |
615 | (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) | |
616 | (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) | |
617 | (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) | |
618 | cl-tree (cons a d)))) | |
619 | (t cl-tree))) | |
620 | ||
621 | (defun cl-acons (key value alist) | |
622 | "Add KEY and VALUE to ALIST. | |
623 | Return a new list with (cons KEY VALUE) as car and ALIST as cdr." | |
624 | (cons (cons key value) alist)) | |
625 | ||
626 | (defun cl-pairlis (keys values &optional alist) | |
627 | "Make an alist from KEYS and VALUES. | |
628 | Return a new alist composed by associating KEYS to corresponding VALUES; | |
629 | the process stops as soon as KEYS or VALUES run out. | |
630 | If ALIST is non-nil, the new pairs are prepended to it." | |
631 | (nconc (cl-mapcar 'cons keys values) alist)) | |
632 | ||
633 | ||
634 | ;;; Miscellaneous. | |
635 | ||
636 | ;;;###autoload | |
637 | (progn | |
638 | ;; Autoload, so autoload.el and font-lock can use it even when CL | |
639 | ;; is not loaded. | |
640 | (put 'cl-defun 'doc-string-elt 3) | |
641 | (put 'cl-defmacro 'doc-string-elt 3) | |
642 | (put 'cl-defsubst 'doc-string-elt 3) | |
643 | (put 'cl-defstruct 'doc-string-elt 2)) | |
644 | ||
645 | (load "cl-loaddefs" nil 'quiet) | |
646 | ||
7c1898a7 SM |
647 | (provide 'cl-lib) |
648 | ||
649 | (run-hooks 'cl-load-hook) | |
650 | ||
651 | ;; Local variables: | |
652 | ;; byte-compile-dynamic: t | |
653 | ;; byte-compile-warnings: (not cl-functions) | |
654 | ;; End: | |
655 | ||
656 | ;;; cl-lib.el ends here |