Commit | Line | Data |
---|---|---|
bb3faf5b | 1 | ;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*- |
7c1898a7 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1993, 2001-2014 Free Software Foundation, Inc. |
7c1898a7 SM |
4 | |
5 | ;; Author: Dave Gillespie <daveg@synaptics.com> | |
cdc5d88c | 6 | ;; Version: 1.0 |
7c1898a7 SM |
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 | ||
7c1898a7 SM |
39 | ;;; Change Log: |
40 | ||
41 | ;; Version 2.02 (30 Jul 93): | |
42 | ;; * Added "cl-compat.el" file, extra compatibility with old package. | |
43 | ;; * Added `lexical-let' and `lexical-let*'. | |
44 | ;; * Added `define-modify-macro', `callf', and `callf2'. | |
45 | ;; * Added `ignore-errors'. | |
46 | ;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero. | |
47 | ;; * Merged `*gentemp-counter*' into `*gensym-counter*'. | |
48 | ;; * Extended `subseq' to allow negative START and END like `substring'. | |
49 | ;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses. | |
50 | ;; * Added `concat', `vconcat' loop clauses. | |
51 | ;; * Cleaned up a number of compiler warnings. | |
52 | ||
53 | ;; Version 2.01 (7 Jul 93): | |
54 | ;; * Added support for FSF version of Emacs 19. | |
55 | ;; * Added `add-hook' for Emacs 18 users. | |
56 | ;; * Added `defsubst*' and `symbol-macrolet'. | |
57 | ;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'. | |
58 | ;; * Added `map', `concatenate', `reduce', `merge'. | |
59 | ;; * Added `revappend', `nreconc', `tailp', `tree-equal'. | |
60 | ;; * Added `assert', `check-type', `typecase', `typep', and `deftype'. | |
61 | ;; * Added destructuring and `&environment' support to `defmacro*'. | |
62 | ;; * Added destructuring to `loop', and added the following clauses: | |
63 | ;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'. | |
64 | ;; * Renamed `delete' to `delete*' and `remove' to `remove*'. | |
65 | ;; * Completed support for all keywords in `remove*', `substitute', etc. | |
66 | ;; * Added `most-positive-float' and company. | |
67 | ;; * Fixed hash tables to work with latest Lucid Emacs. | |
68 | ;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'. | |
69 | ;; * Syntax for `warn' declarations has changed. | |
70 | ;; * Improved implementation of `random*'. | |
71 | ;; * Moved most sequence functions to a new file, cl-seq.el. | |
72 | ;; * Moved `eval-when' into cl-macs.el. | |
73 | ;; * Moved `pushnew' and `adjoin' to cl.el for most common cases. | |
74 | ;; * Moved `provide' forms down to ends of files. | |
75 | ;; * Changed expansion of `pop' to something that compiles to better code. | |
76 | ;; * Changed so that no patch is required for Emacs 19 byte compiler. | |
77 | ;; * Made more things dependent on `optimize' declarations. | |
78 | ;; * Added a partial implementation of struct print functions. | |
79 | ;; * Miscellaneous minor changes. | |
80 | ||
81 | ;; Version 2.00: | |
82 | ;; * First public release of this package. | |
83 | ||
84 | ||
85 | ;;; Code: | |
86 | ||
40c2a143 | 87 | (require 'macroexp) |
ac10fe06 | 88 | |
338bfefa SM |
89 | (defvar cl--optimize-speed 1) |
90 | (defvar cl--optimize-safety 1) | |
7c1898a7 | 91 | |
57a7d507 SM |
92 | ;;;###autoload |
93 | (define-obsolete-variable-alias | |
94 | ;; This alias is needed for compatibility with .elc files that use defstruct | |
2a1e2476 GM |
95 | ;; and were compiled with Emacs<24.3. |
96 | 'custom-print-functions 'cl-custom-print-functions "24.3") | |
7c1898a7 SM |
97 | |
98 | ;;;###autoload | |
99 | (defvar cl-custom-print-functions nil | |
100 | "This is a list of functions that format user objects for printing. | |
101 | Each function is called in turn with three arguments: the object, the | |
102 | stream, and the print level (currently ignored). If it is able to | |
103 | print the object it returns true; otherwise it returns nil and the | |
104 | printer proceeds to the next function on the list. | |
105 | ||
106 | This variable is not used at present, but it is defined in hopes that | |
107 | a future Emacs interpreter will be able to use it.") | |
108 | ||
7c1898a7 SM |
109 | ;;; Generalized variables. |
110 | ;; These macros are defined here so that they | |
865fe16f | 111 | ;; can safely be used in init files. |
7c1898a7 SM |
112 | |
113 | (defmacro cl-incf (place &optional x) | |
114 | "Increment PLACE by X (1 by default). | |
2ee3d7f0 | 115 | PLACE may be a symbol, or any generalized variable allowed by `setf'. |
7c1898a7 SM |
116 | The return value is the incremented value of PLACE." |
117 | (declare (debug (place &optional form))) | |
118 | (if (symbolp place) | |
119 | (list 'setq place (if x (list '+ place x) (list '1+ place))) | |
120 | (list 'cl-callf '+ place (or x 1)))) | |
121 | ||
122 | (defmacro cl-decf (place &optional x) | |
123 | "Decrement PLACE by X (1 by default). | |
2ee3d7f0 | 124 | PLACE may be a symbol, or any generalized variable allowed by `setf'. |
7c1898a7 SM |
125 | The return value is the decremented value of PLACE." |
126 | (declare (debug cl-incf)) | |
127 | (if (symbolp place) | |
128 | (list 'setq place (if x (list '- place x) (list '1- place))) | |
129 | (list 'cl-callf '- place (or x 1)))) | |
130 | ||
7c1898a7 SM |
131 | (defmacro cl-pushnew (x place &rest keys) |
132 | "(cl-pushnew X PLACE): insert X at the head of the list if not already there. | |
2ee3d7f0 | 133 | Like (push X PLACE), except that the list is unmodified if X is `eql' to |
7c1898a7 SM |
134 | an element already on the list. |
135 | \nKeywords supported: :test :test-not :key | |
136 | \n(fn X PLACE [KEYWORD VALUE]...)" | |
137 | (declare (debug | |
138 | (form place &rest | |
139 | &or [[&or ":test" ":test-not" ":key"] function-form] | |
140 | [keywordp form]))) | |
141 | (if (symbolp place) | |
142 | (if (null keys) | |
3cfbebba SM |
143 | (macroexp-let2 nil var x |
144 | `(if (memql ,var ,place) | |
145 | ;; This symbol may later on expand to actual code which then | |
146 | ;; trigger warnings like "value unused" since cl-pushnew's | |
147 | ;; return value is rarely used. It should not matter that | |
148 | ;; other warnings may be silenced, since `place' is used | |
149 | ;; earlier and should have triggered them already. | |
150 | (with-no-warnings ,place) | |
151 | (setq ,place (cons ,var ,place)))) | |
208d0342 SM |
152 | `(setq ,place (cl-adjoin ,x ,place ,@keys))) |
153 | `(cl-callf2 cl-adjoin ,x ,place ,@keys))) | |
7c1898a7 | 154 | |
bb3faf5b | 155 | (defun cl--set-elt (seq n val) |
7c1898a7 SM |
156 | (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) |
157 | ||
bb3faf5b | 158 | (defun cl--set-buffer-substring (start end val) |
7c1898a7 SM |
159 | (save-excursion (delete-region start end) |
160 | (goto-char start) | |
161 | (insert val) | |
162 | val)) | |
163 | ||
bb3faf5b | 164 | (defun cl--set-substring (str start end val) |
7c1898a7 SM |
165 | (if end (if (< end 0) (cl-incf end (length str))) |
166 | (setq end (length str))) | |
167 | (if (< start 0) (cl-incf start (length str))) | |
168 | (concat (and (> start 0) (substring str 0 start)) | |
169 | val | |
170 | (and (< end (length str)) (substring str end)))) | |
171 | ||
172 | ||
7c1898a7 SM |
173 | ;;; Blocks and exits. |
174 | ||
bb3faf5b SM |
175 | (defalias 'cl--block-wrapper 'identity) |
176 | (defalias 'cl--block-throw 'throw) | |
7c1898a7 SM |
177 | |
178 | ||
179 | ;;; Multiple values. | |
180 | ;; True multiple values are not supported, or even | |
181 | ;; simulated. Instead, cl-multiple-value-bind and friends simply expect | |
182 | ;; the target form to return the values as a list. | |
183 | ||
71adb94b SM |
184 | (defun cl--defalias (cl-f el-f &optional doc) |
185 | (defalias cl-f el-f doc) | |
186 | (put cl-f 'byte-optimizer 'byte-compile-inline-expand)) | |
187 | ||
188 | (cl--defalias 'cl-values #'list | |
7c1898a7 SM |
189 | "Return multiple values, Common Lisp style. |
190 | The arguments of `cl-values' are the values | |
191 | that the containing function should return. | |
192 | ||
193 | \(fn &rest VALUES)") | |
194 | ||
71adb94b | 195 | (cl--defalias 'cl-values-list #'identity |
7c1898a7 SM |
196 | "Return multiple values, Common Lisp style, taken from a list. |
197 | LIST specifies the list of values | |
198 | that the containing function should return. | |
199 | ||
200 | \(fn LIST)") | |
201 | ||
202 | (defsubst cl-multiple-value-list (expression) | |
203 | "Return a list of the multiple values produced by EXPRESSION. | |
204 | This handles multiple values in Common Lisp style, but it does not | |
205 | work right when EXPRESSION calls an ordinary Emacs Lisp function | |
206 | that returns just one value." | |
207 | expression) | |
208 | ||
209 | (defsubst cl-multiple-value-apply (function expression) | |
210 | "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. | |
211 | This handles multiple values in Common Lisp style, but it does not work | |
212 | right when EXPRESSION calls an ordinary Emacs Lisp function that returns just | |
213 | one value." | |
214 | (apply function expression)) | |
215 | ||
216 | (defalias 'cl-multiple-value-call 'apply | |
217 | "Apply FUNCTION to ARGUMENTS, taking multiple values into account. | |
218 | This implementation only handles the case where there is only one argument.") | |
219 | ||
a464a6c7 | 220 | (cl--defalias 'cl-nth-value #'nth |
7c1898a7 SM |
221 | "Evaluate EXPRESSION to get multiple values and return the Nth one. |
222 | This handles multiple values in Common Lisp style, but it does not work | |
223 | right when EXPRESSION calls an ordinary Emacs Lisp function that returns just | |
a464a6c7 SM |
224 | one value. |
225 | ||
226 | \(fn N EXPRESSION)") | |
7c1898a7 | 227 | |
7c1898a7 SM |
228 | ;;; Declarations. |
229 | ||
bb3faf5b SM |
230 | (defvar cl--compiling-file nil) |
231 | (defun cl--compiling-file () | |
232 | (or cl--compiling-file | |
7c1898a7 SM |
233 | (and (boundp 'byte-compile--outbuffer) |
234 | (bufferp (symbol-value 'byte-compile--outbuffer)) | |
235 | (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) | |
236 | " *Compiler Output*")))) | |
237 | ||
338bfefa | 238 | (defvar cl--proclaims-deferred nil) |
7c1898a7 SM |
239 | |
240 | (defun cl-proclaim (spec) | |
5593ed90 | 241 | "Record a global declaration specified by SPEC." |
338bfefa SM |
242 | (if (fboundp 'cl--do-proclaim) (cl--do-proclaim spec t) |
243 | (push spec cl--proclaims-deferred)) | |
7c1898a7 SM |
244 | nil) |
245 | ||
246 | (defmacro cl-declaim (&rest specs) | |
5593ed90 GM |
247 | "Like `cl-proclaim', but takes any number of unevaluated, unquoted arguments. |
248 | Puts `(cl-eval-when (compile load eval) ...)' around the declarations | |
249 | so that they are registered at compile-time as well as run-time." | |
bad162fd | 250 | (let ((body (mapcar (lambda (x) `(cl-proclaim ',x)) specs))) |
338bfefa SM |
251 | (if (cl--compiling-file) `(cl-eval-when (compile load eval) ,@body) |
252 | `(progn ,@body)))) ; Avoid loading cl-macs.el for cl-eval-when. | |
7c1898a7 SM |
253 | |
254 | ||
255 | ;;; Symbols. | |
256 | ||
376a8e83 | 257 | (defun cl--random-time () |
7c1898a7 SM |
258 | (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) |
259 | (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) | |
260 | v)) | |
261 | ||
376a8e83 | 262 | (defvar cl--gensym-counter (* (logand (cl--random-time) 1023) 100)) |
7c1898a7 SM |
263 | |
264 | ||
265 | ;;; Numbers. | |
266 | ||
1dfcc79e | 267 | (define-obsolete-function-alias 'cl-floatp-safe 'floatp "24.4") |
7c1898a7 | 268 | |
71adb94b | 269 | (defsubst cl-plusp (number) |
7c1898a7 SM |
270 | "Return t if NUMBER is positive." |
271 | (> number 0)) | |
272 | ||
71adb94b | 273 | (defsubst cl-minusp (number) |
7c1898a7 SM |
274 | "Return t if NUMBER is negative." |
275 | (< number 0)) | |
276 | ||
277 | (defun cl-oddp (integer) | |
278 | "Return t if INTEGER is odd." | |
279 | (eq (logand integer 1) 1)) | |
280 | ||
281 | (defun cl-evenp (integer) | |
282 | "Return t if INTEGER is even." | |
283 | (eq (logand integer 1) 0)) | |
284 | ||
338bfefa SM |
285 | (defvar cl--random-state |
286 | (vector 'cl--random-state-tag -1 30 (cl--random-time))) | |
7c1898a7 SM |
287 | |
288 | (defconst cl-most-positive-float nil | |
289 | "The largest value that a Lisp float can hold. | |
290 | If your system supports infinities, this is the largest finite value. | |
291 | For IEEE machines, this is approximately 1.79e+308. | |
292 | Call `cl-float-limits' to set this.") | |
293 | ||
294 | (defconst cl-most-negative-float nil | |
295 | "The largest negative value that a Lisp float can hold. | |
296 | This is simply -`cl-most-positive-float'. | |
297 | Call `cl-float-limits' to set this.") | |
298 | ||
299 | (defconst cl-least-positive-float nil | |
300 | "The smallest value greater than zero that a Lisp float can hold. | |
301 | For IEEE machines, it is about 4.94e-324 if denormals are supported, | |
302 | or 2.22e-308 if they are not. | |
303 | Call `cl-float-limits' to set this.") | |
304 | ||
305 | (defconst cl-least-negative-float nil | |
306 | "The smallest value less than zero that a Lisp float can hold. | |
307 | This is simply -`cl-least-positive-float'. | |
308 | Call `cl-float-limits' to set this.") | |
309 | ||
310 | (defconst cl-least-positive-normalized-float nil | |
311 | "The smallest normalized Lisp float greater than zero. | |
312 | This is the smallest value for which IEEE denormalization does not lose | |
313 | precision. For IEEE machines, this value is about 2.22e-308. | |
314 | For machines that do not support the concept of denormalization | |
315 | and gradual underflow, this constant equals `cl-least-positive-float'. | |
316 | Call `cl-float-limits' to set this.") | |
317 | ||
318 | (defconst cl-least-negative-normalized-float nil | |
319 | "The smallest normalized Lisp float less than zero. | |
320 | This is simply -`cl-least-positive-normalized-float'. | |
321 | Call `cl-float-limits' to set this.") | |
322 | ||
323 | (defconst cl-float-epsilon nil | |
324 | "The smallest positive float that adds to 1.0 to give a distinct value. | |
325 | Adding a number less than this to 1.0 returns 1.0 due to roundoff. | |
326 | For IEEE machines, epsilon is about 2.22e-16. | |
327 | Call `cl-float-limits' to set this.") | |
328 | ||
329 | (defconst cl-float-negative-epsilon nil | |
330 | "The smallest positive float that subtracts from 1.0 to give a distinct value. | |
331 | For IEEE machines, it is about 1.11e-16. | |
332 | Call `cl-float-limits' to set this.") | |
333 | ||
334 | ||
335 | ;;; Sequence functions. | |
336 | ||
71adb94b | 337 | (cl--defalias 'cl-copy-seq 'copy-sequence) |
7c1898a7 | 338 | |
bb3faf5b | 339 | (declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs)) |
7c1898a7 SM |
340 | |
341 | (defun cl-mapcar (cl-func cl-x &rest cl-rest) | |
342 | "Apply FUNCTION to each element of SEQ, and make a list of the results. | |
343 | If there are several SEQs, FUNCTION is called with that many arguments, | |
344 | and mapping stops as soon as the shortest list runs out. With just one | |
345 | SEQ, this is like `mapcar'. With several, it is like the Common Lisp | |
346 | `mapcar' function extended to arbitrary sequence types. | |
347 | \n(fn FUNCTION SEQ...)" | |
348 | (if cl-rest | |
349 | (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) | |
bb3faf5b | 350 | (cl--mapcar-many cl-func (cons cl-x cl-rest)) |
7c1898a7 SM |
351 | (let ((cl-res nil) (cl-y (car cl-rest))) |
352 | (while (and cl-x cl-y) | |
353 | (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) | |
354 | (nreverse cl-res))) | |
355 | (mapcar cl-func cl-x))) | |
356 | ||
71adb94b | 357 | (cl--defalias 'cl-svref 'aref) |
7c1898a7 SM |
358 | |
359 | ;;; List functions. | |
360 | ||
71adb94b SM |
361 | (cl--defalias 'cl-first 'car) |
362 | (cl--defalias 'cl-second 'cadr) | |
363 | (cl--defalias 'cl-rest 'cdr) | |
364 | (cl--defalias 'cl-endp 'null) | |
7c1898a7 | 365 | |
71adb94b SM |
366 | (cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.") |
367 | (cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.") | |
7c1898a7 | 368 | |
71adb94b SM |
369 | (defsubst cl-fifth (x) |
370 | "Return the fifth element of the list X." | |
36cec983 | 371 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 4 ,x) ,store)))) |
7c1898a7 SM |
372 | (nth 4 x)) |
373 | ||
71adb94b SM |
374 | (defsubst cl-sixth (x) |
375 | "Return the sixth element of the list X." | |
36cec983 | 376 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 5 ,x) ,store)))) |
7c1898a7 SM |
377 | (nth 5 x)) |
378 | ||
71adb94b SM |
379 | (defsubst cl-seventh (x) |
380 | "Return the seventh element of the list X." | |
36cec983 | 381 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 6 ,x) ,store)))) |
7c1898a7 SM |
382 | (nth 6 x)) |
383 | ||
71adb94b SM |
384 | (defsubst cl-eighth (x) |
385 | "Return the eighth element of the list X." | |
36cec983 | 386 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 7 ,x) ,store)))) |
7c1898a7 SM |
387 | (nth 7 x)) |
388 | ||
71adb94b SM |
389 | (defsubst cl-ninth (x) |
390 | "Return the ninth element of the list X." | |
36cec983 | 391 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 8 ,x) ,store)))) |
7c1898a7 SM |
392 | (nth 8 x)) |
393 | ||
71adb94b SM |
394 | (defsubst cl-tenth (x) |
395 | "Return the tenth element of the list X." | |
36cec983 | 396 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store)))) |
7c1898a7 SM |
397 | (nth 9 x)) |
398 | ||
399 | (defun cl-caaar (x) | |
400 | "Return the `car' of the `car' of the `car' of X." | |
71adb94b | 401 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
402 | (car (car (car x)))) |
403 | ||
404 | (defun cl-caadr (x) | |
405 | "Return the `car' of the `car' of the `cdr' of X." | |
71adb94b | 406 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
407 | (car (car (cdr x)))) |
408 | ||
409 | (defun cl-cadar (x) | |
410 | "Return the `car' of the `cdr' of the `car' of X." | |
71adb94b | 411 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
412 | (car (cdr (car x)))) |
413 | ||
414 | (defun cl-caddr (x) | |
415 | "Return the `car' of the `cdr' of the `cdr' of X." | |
71adb94b | 416 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
417 | (car (cdr (cdr x)))) |
418 | ||
419 | (defun cl-cdaar (x) | |
420 | "Return the `cdr' of the `car' of the `car' of X." | |
71adb94b | 421 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
422 | (cdr (car (car x)))) |
423 | ||
424 | (defun cl-cdadr (x) | |
425 | "Return the `cdr' of the `car' of the `cdr' of X." | |
71adb94b | 426 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
427 | (cdr (car (cdr x)))) |
428 | ||
429 | (defun cl-cddar (x) | |
430 | "Return the `cdr' of the `cdr' of the `car' of X." | |
71adb94b | 431 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
432 | (cdr (cdr (car x)))) |
433 | ||
434 | (defun cl-cdddr (x) | |
435 | "Return the `cdr' of the `cdr' of the `cdr' of X." | |
71adb94b | 436 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
437 | (cdr (cdr (cdr x)))) |
438 | ||
439 | (defun cl-caaaar (x) | |
440 | "Return the `car' of the `car' of the `car' of the `car' of X." | |
71adb94b | 441 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
442 | (car (car (car (car x))))) |
443 | ||
444 | (defun cl-caaadr (x) | |
445 | "Return the `car' of the `car' of the `car' of the `cdr' of X." | |
71adb94b | 446 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
447 | (car (car (car (cdr x))))) |
448 | ||
449 | (defun cl-caadar (x) | |
450 | "Return the `car' of the `car' of the `cdr' of the `car' of X." | |
71adb94b | 451 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
452 | (car (car (cdr (car x))))) |
453 | ||
454 | (defun cl-caaddr (x) | |
455 | "Return the `car' of the `car' of the `cdr' of the `cdr' of X." | |
71adb94b | 456 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
457 | (car (car (cdr (cdr x))))) |
458 | ||
459 | (defun cl-cadaar (x) | |
460 | "Return the `car' of the `cdr' of the `car' of the `car' of X." | |
71adb94b | 461 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
462 | (car (cdr (car (car x))))) |
463 | ||
464 | (defun cl-cadadr (x) | |
465 | "Return the `car' of the `cdr' of the `car' of the `cdr' of X." | |
71adb94b | 466 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
467 | (car (cdr (car (cdr x))))) |
468 | ||
469 | (defun cl-caddar (x) | |
470 | "Return the `car' of the `cdr' of the `cdr' of the `car' of X." | |
71adb94b | 471 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
472 | (car (cdr (cdr (car x))))) |
473 | ||
474 | (defun cl-cadddr (x) | |
475 | "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." | |
71adb94b | 476 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
477 | (car (cdr (cdr (cdr x))))) |
478 | ||
479 | (defun cl-cdaaar (x) | |
480 | "Return the `cdr' of the `car' of the `car' of the `car' of X." | |
71adb94b | 481 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
482 | (cdr (car (car (car x))))) |
483 | ||
484 | (defun cl-cdaadr (x) | |
485 | "Return the `cdr' of the `car' of the `car' of the `cdr' of X." | |
71adb94b | 486 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
487 | (cdr (car (car (cdr x))))) |
488 | ||
489 | (defun cl-cdadar (x) | |
490 | "Return the `cdr' of the `car' of the `cdr' of the `car' of X." | |
71adb94b | 491 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
492 | (cdr (car (cdr (car x))))) |
493 | ||
494 | (defun cl-cdaddr (x) | |
495 | "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." | |
71adb94b | 496 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
497 | (cdr (car (cdr (cdr x))))) |
498 | ||
499 | (defun cl-cddaar (x) | |
500 | "Return the `cdr' of the `cdr' of the `car' of the `car' of X." | |
71adb94b | 501 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
502 | (cdr (cdr (car (car x))))) |
503 | ||
504 | (defun cl-cddadr (x) | |
505 | "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." | |
71adb94b | 506 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
507 | (cdr (cdr (car (cdr x))))) |
508 | ||
509 | (defun cl-cdddar (x) | |
510 | "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." | |
71adb94b | 511 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
512 | (cdr (cdr (cdr (car x))))) |
513 | ||
514 | (defun cl-cddddr (x) | |
515 | "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." | |
71adb94b | 516 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
7c1898a7 SM |
517 | (cdr (cdr (cdr (cdr x))))) |
518 | ||
519 | ;;(defun last* (x &optional n) | |
520 | ;; "Returns the last link in the list LIST. | |
521 | ;;With optional argument N, returns Nth-to-last link (default 1)." | |
522 | ;; (if n | |
523 | ;; (let ((m 0) (p x)) | |
524 | ;; (while (consp p) (cl-incf m) (pop p)) | |
525 | ;; (if (<= n 0) p | |
526 | ;; (if (< n m) (nthcdr (- m n) x) x))) | |
527 | ;; (while (consp (cdr x)) (pop x)) | |
528 | ;; x)) | |
529 | ||
d9857e53 | 530 | (defun cl-list* (arg &rest rest) |
7c1898a7 SM |
531 | "Return a new list with specified ARGs as elements, consed to last ARG. |
532 | Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to | |
533 | `(cons A (cons B (cons C D)))'. | |
534 | \n(fn ARG...)" | |
d9857e53 | 535 | (declare (compiler-macro cl--compiler-macro-list*)) |
7c1898a7 SM |
536 | (cond ((not rest) arg) |
537 | ((not (cdr rest)) (cons arg (car rest))) | |
538 | (t (let* ((n (length rest)) | |
539 | (copy (copy-sequence rest)) | |
540 | (last (nthcdr (- n 2) copy))) | |
541 | (setcdr last (car (cdr last))) | |
542 | (cons arg copy))))) | |
543 | ||
544 | (defun cl-ldiff (list sublist) | |
545 | "Return a copy of LIST with the tail SUBLIST removed." | |
546 | (let ((res nil)) | |
547 | (while (and (consp list) (not (eq list sublist))) | |
548 | (push (pop list) res)) | |
549 | (nreverse res))) | |
550 | ||
551 | (defun cl-copy-list (list) | |
552 | "Return a copy of LIST, which may be a dotted list. | |
553 | The elements of LIST are not copied, just the list structure itself." | |
554 | (if (consp list) | |
555 | (let ((res nil)) | |
556 | (while (consp list) (push (pop list) res)) | |
557 | (prog1 (nreverse res) (setcdr res list))) | |
558 | (car list))) | |
559 | ||
7c1898a7 SM |
560 | ;; Autoloaded, but we have not loaded cl-loaddefs yet. |
561 | (declare-function cl-floor "cl-extra" (x &optional y)) | |
562 | (declare-function cl-ceiling "cl-extra" (x &optional y)) | |
563 | (declare-function cl-truncate "cl-extra" (x &optional y)) | |
564 | (declare-function cl-round "cl-extra" (x &optional y)) | |
565 | (declare-function cl-mod "cl-extra" (x y)) | |
566 | ||
d9857e53 | 567 | (defun cl-adjoin (cl-item cl-list &rest cl-keys) |
7c1898a7 SM |
568 | "Return ITEM consed onto the front of LIST only if it's not already there. |
569 | Otherwise, return LIST unmodified. | |
570 | \nKeywords supported: :test :test-not :key | |
571 | \n(fn ITEM LIST [KEYWORD VALUE]...)" | |
d9857e53 | 572 | (declare (compiler-macro cl--compiler-macro-adjoin)) |
7c1898a7 SM |
573 | (cond ((or (equal cl-keys '(:test eq)) |
574 | (and (null cl-keys) (not (numberp cl-item)))) | |
575 | (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) | |
576 | ((or (equal cl-keys '(:test equal)) (null cl-keys)) | |
577 | (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) | |
578 | (t (apply 'cl--adjoin cl-item cl-list cl-keys)))) | |
579 | ||
580 | (defun cl-subst (cl-new cl-old cl-tree &rest cl-keys) | |
581 | "Substitute NEW for OLD everywhere in TREE (non-destructively). | |
582 | Return a copy of TREE with all elements `eql' to OLD replaced by NEW. | |
583 | \nKeywords supported: :test :test-not :key | |
584 | \n(fn NEW OLD TREE [KEYWORD VALUE]...)" | |
585 | (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) | |
586 | (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys) | |
bb3faf5b | 587 | (cl--do-subst cl-new cl-old cl-tree))) |
7c1898a7 | 588 | |
bb3faf5b | 589 | (defun cl--do-subst (cl-new cl-old cl-tree) |
7c1898a7 SM |
590 | (cond ((eq cl-tree cl-old) cl-new) |
591 | ((consp cl-tree) | |
bb3faf5b SM |
592 | (let ((a (cl--do-subst cl-new cl-old (car cl-tree))) |
593 | (d (cl--do-subst cl-new cl-old (cdr cl-tree)))) | |
7c1898a7 SM |
594 | (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) |
595 | cl-tree (cons a d)))) | |
596 | (t cl-tree))) | |
597 | ||
598 | (defun cl-acons (key value alist) | |
599 | "Add KEY and VALUE to ALIST. | |
600 | Return a new list with (cons KEY VALUE) as car and ALIST as cdr." | |
601 | (cons (cons key value) alist)) | |
602 | ||
603 | (defun cl-pairlis (keys values &optional alist) | |
604 | "Make an alist from KEYS and VALUES. | |
605 | Return a new alist composed by associating KEYS to corresponding VALUES; | |
606 | the process stops as soon as KEYS or VALUES run out. | |
607 | If ALIST is non-nil, the new pairs are prepended to it." | |
608 | (nconc (cl-mapcar 'cons keys values) alist)) | |
609 | ||
610 | ||
36cec983 SM |
611 | ;;; Generalized variables. |
612 | ||
613 | ;; These used to be in cl-macs.el since all macros that use them (like setf) | |
614 | ;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in | |
615 | ;; core Elisp, they need to either be right here or be autoloaded via | |
616 | ;; cl-loaddefs.el, which is more trouble than it is worth. | |
617 | ||
618 | ;; Some more Emacs-related place types. | |
619 | (gv-define-simple-setter buffer-file-name set-visited-file-name t) | |
620 | (gv-define-setter buffer-modified-p (flag &optional buf) | |
621 | `(with-current-buffer ,buf | |
622 | (set-buffer-modified-p ,flag))) | |
623 | (gv-define-simple-setter buffer-name rename-buffer t) | |
624 | (gv-define-setter buffer-string (store) | |
d5e2bcd3 | 625 | `(insert (prog1 ,store (erase-buffer)))) |
36cec983 SM |
626 | (gv-define-simple-setter buffer-substring cl--set-buffer-substring) |
627 | (gv-define-simple-setter current-buffer set-buffer) | |
628 | (gv-define-simple-setter current-case-table set-case-table) | |
629 | (gv-define-simple-setter current-column move-to-column t) | |
630 | (gv-define-simple-setter current-global-map use-global-map t) | |
631 | (gv-define-setter current-input-mode (store) | |
632 | `(progn (apply #'set-input-mode ,store) ,store)) | |
633 | (gv-define-simple-setter current-local-map use-local-map t) | |
634 | (gv-define-simple-setter current-window-configuration | |
635 | set-window-configuration t) | |
636 | (gv-define-simple-setter default-file-modes set-default-file-modes t) | |
637 | (gv-define-simple-setter documentation-property put) | |
638 | (gv-define-setter face-background (x f &optional s) | |
639 | `(set-face-background ,f ,x ,s)) | |
640 | (gv-define-setter face-background-pixmap (x f &optional s) | |
641 | `(set-face-background-pixmap ,f ,x ,s)) | |
642 | (gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) | |
643 | (gv-define-setter face-foreground (x f &optional s) | |
644 | `(set-face-foreground ,f ,x ,s)) | |
645 | (gv-define-setter face-underline-p (x f &optional s) | |
9a5e2ee3 | 646 | `(set-face-underline ,f ,x ,s)) |
36cec983 SM |
647 | (gv-define-simple-setter file-modes set-file-modes t) |
648 | (gv-define-simple-setter frame-height set-screen-height t) | |
649 | (gv-define-simple-setter frame-parameters modify-frame-parameters t) | |
650 | (gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) | |
651 | (gv-define-simple-setter frame-width set-screen-width t) | |
652 | (gv-define-simple-setter getenv setenv t) | |
653 | (gv-define-simple-setter get-register set-register) | |
654 | (gv-define-simple-setter global-key-binding global-set-key) | |
655 | (gv-define-simple-setter local-key-binding local-set-key) | |
656 | (gv-define-simple-setter mark set-mark t) | |
657 | (gv-define-simple-setter mark-marker set-mark t) | |
658 | (gv-define-simple-setter marker-position set-marker t) | |
659 | (gv-define-setter mouse-position (store scr) | |
660 | `(set-mouse-position ,scr (car ,store) (cadr ,store) | |
661 | (cddr ,store))) | |
662 | (gv-define-simple-setter point goto-char) | |
663 | (gv-define-simple-setter point-marker goto-char t) | |
664 | (gv-define-setter point-max (store) | |
665 | `(progn (narrow-to-region (point-min) ,store) ,store)) | |
666 | (gv-define-setter point-min (store) | |
667 | `(progn (narrow-to-region ,store (point-max)) ,store)) | |
668 | (gv-define-setter read-mouse-position (store scr) | |
669 | `(set-mouse-position ,scr (car ,store) (cdr ,store))) | |
670 | (gv-define-simple-setter screen-height set-screen-height t) | |
671 | (gv-define-simple-setter screen-width set-screen-width t) | |
672 | (gv-define-simple-setter selected-window select-window) | |
673 | (gv-define-simple-setter selected-screen select-screen) | |
674 | (gv-define-simple-setter selected-frame select-frame) | |
675 | (gv-define-simple-setter standard-case-table set-standard-case-table) | |
676 | (gv-define-simple-setter syntax-table set-syntax-table) | |
677 | (gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) | |
678 | (gv-define-setter window-height (store) | |
679 | `(progn (enlarge-window (- ,store (window-height))) ,store)) | |
680 | (gv-define-setter window-width (store) | |
681 | `(progn (enlarge-window (- ,store (window-width)) t) ,store)) | |
682 | (gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) | |
683 | (gv-define-simple-setter x-get-selection x-own-selection t) | |
684 | ||
685 | ;; More complex setf-methods. | |
686 | ||
687 | ;; This is a hack that allows (setf (eq a 7) B) to mean either | |
688 | ;; (setq a 7) or (setq a nil) depending on whether B is nil or not. | |
689 | ;; This is useful when you have control over the PLACE but not over | |
690 | ;; the VALUE, as is the case in define-minor-mode's :variable. | |
691 | ;; It turned out that :variable needed more flexibility anyway, so | |
692 | ;; this doesn't seem too useful now. | |
693 | (gv-define-expander eq | |
694 | (lambda (do place val) | |
695 | (gv-letplace (getter setter) place | |
696 | (macroexp-let2 nil val val | |
697 | (funcall do `(eq ,getter ,val) | |
698 | (lambda (v) | |
699 | `(cond | |
700 | (,v ,(funcall setter val)) | |
701 | ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) | |
702 | ||
703 | (gv-define-expander substring | |
704 | (lambda (do place from &optional to) | |
705 | (gv-letplace (getter setter) place | |
706 | (macroexp-let2 nil start from | |
707 | (macroexp-let2 nil end to | |
708 | (funcall do `(substring ,getter ,start ,end) | |
709 | (lambda (v) | |
710 | (funcall setter `(cl--set-substring | |
711 | ,getter ,start ,end ,v))))))))) | |
712 | ||
7c1898a7 SM |
713 | ;;; Miscellaneous. |
714 | ||
715 | ;;;###autoload | |
716 | (progn | |
54bd972f SM |
717 | ;; The `assert' macro from the cl package signals |
718 | ;; `cl-assertion-failed' at runtime so always define it. | |
719 | (define-error 'cl-assertion-failed (purecopy "Assertion failed")) | |
9f1a4aa5 SM |
720 | ;; Make sure functions defined with cl-defsubst can be inlined even in |
721 | ;; packages which do not require CL. We don't put an autoload cookie | |
722 | ;; directly on that function, since those cookies only go to cl-loaddefs. | |
723 | (autoload 'cl--defsubst-expand "cl-macs") | |
7c1898a7 SM |
724 | ;; Autoload, so autoload.el and font-lock can use it even when CL |
725 | ;; is not loaded. | |
726 | (put 'cl-defun 'doc-string-elt 3) | |
727 | (put 'cl-defmacro 'doc-string-elt 3) | |
728 | (put 'cl-defsubst 'doc-string-elt 3) | |
729 | (put 'cl-defstruct 'doc-string-elt 2)) | |
730 | ||
7c1898a7 | 731 | (provide 'cl-lib) |
aff6371e SM |
732 | (or (load "cl-loaddefs" 'noerror 'quiet) |
733 | ;; When bootstrapping, cl-loaddefs hasn't been built yet! | |
734 | (require 'cl-macs)) | |
7c1898a7 | 735 | |
7c1898a7 SM |
736 | ;; Local variables: |
737 | ;; byte-compile-dynamic: t | |
7c1898a7 SM |
738 | ;; End: |
739 | ||
740 | ;;; cl-lib.el ends here |