Commit | Line | Data |
---|---|---|
87787319 | 1 | ;;; cl.el --- Common Lisp extensions for Emacs |
fcd73769 | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc. |
fcd73769 RS |
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 | ||
d6cba7ae | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
fcd73769 | 12 | ;; it under the terms of the GNU General Public License as published by |
d6cba7ae GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
fcd73769 RS |
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 | |
d6cba7ae | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
fcd73769 | 23 | |
07b3798c | 24 | ;;; Commentary: |
fcd73769 RS |
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 | ;; | |
fcd73769 RS |
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 | ||
07b3798c | 39 | ;;; Future notes: |
fcd73769 RS |
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 | ||
07b3798c | 46 | ;;; Change Log: |
fcd73769 RS |
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 | ||
07b3798c | 92 | ;;; Code: |
fcd73769 | 93 | |
fcd73769 RS |
94 | (defvar cl-optimize-speed 1) |
95 | (defvar cl-optimize-safety 1) | |
96 | ||
97 | ||
7dcf6269 | 98 | ;;;###autoload |
fcd73769 RS |
99 | (defvar 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 | ||
66eed827 JB |
109 | (defun cl-unload-function () |
110 | "Stop unloading of the Common Lisp extensions." | |
111 | (message "Cannot unload the feature `cl'") | |
112 | ;; stop standard unloading! | |
113 | t) | |
fcd73769 | 114 | |
b68f6e48 SM |
115 | ;;; Generalized variables. |
116 | ;; These macros are defined here so that they | |
117 | ;; can safely be used in .emacs files. | |
fcd73769 RS |
118 | |
119 | (defmacro incf (place &optional x) | |
64a4c526 | 120 | "Increment PLACE by X (1 by default). |
fcd73769 RS |
121 | PLACE may be a symbol, or any generalized variable allowed by `setf'. |
122 | The return value is the incremented value of PLACE." | |
123 | (if (symbolp place) | |
124 | (list 'setq place (if x (list '+ place x) (list '1+ place))) | |
125 | (list 'callf '+ place (or x 1)))) | |
126 | ||
127 | (defmacro decf (place &optional x) | |
64a4c526 | 128 | "Decrement PLACE by X (1 by default). |
fcd73769 RS |
129 | PLACE may be a symbol, or any generalized variable allowed by `setf'. |
130 | The return value is the decremented value of PLACE." | |
131 | (if (symbolp place) | |
132 | (list 'setq place (if x (list '- place x) (list '1- place))) | |
133 | (list 'callf '- place (or x 1)))) | |
134 | ||
7467c796 GM |
135 | ;; Autoloaded, but we haven't loaded cl-loaddefs yet. |
136 | (declare-function cl-do-pop "cl-macs" (place)) | |
137 | ||
fcd73769 | 138 | (defmacro pop (place) |
64a4c526 | 139 | "Remove and return the head of the list stored in PLACE. |
fcd73769 RS |
140 | Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more |
141 | careful about evaluating each argument only once and in the right order. | |
142 | PLACE may be a symbol, or any generalized variable allowed by `setf'." | |
143 | (if (symbolp place) | |
144 | (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) | |
145 | (cl-do-pop place))) | |
146 | ||
147 | (defmacro push (x place) | |
64a4c526 | 148 | "Insert X at the head of the list stored in PLACE. |
fcd73769 RS |
149 | Analogous to (setf PLACE (cons X PLACE)), though more careful about |
150 | evaluating each argument only once and in the right order. PLACE may | |
151 | be a symbol, or any generalized variable allowed by `setf'." | |
152 | (if (symbolp place) (list 'setq place (list 'cons x place)) | |
153 | (list 'callf2 'cons x place))) | |
154 | ||
155 | (defmacro pushnew (x place &rest keys) | |
156 | "(pushnew X PLACE): insert X at the head of the list if not already there. | |
157 | Like (push X PLACE), except that the list is unmodified if X is `eql' to | |
158 | an element already on the list. | |
708c63a6 JB |
159 | \nKeywords supported: :test :test-not :key |
160 | \n(fn X PLACE [KEYWORD VALUE]...)" | |
6b34950f RS |
161 | (if (symbolp place) |
162 | (if (null keys) | |
fcecceea | 163 | `(let ((x ,x)) |
ba83908c SM |
164 | (if (memql x ,place) |
165 | ;; This symbol may later on expand to actual code which then | |
166 | ;; trigger warnings like "value unused" since pushnew's return | |
167 | ;; value is rarely used. It should not matter that other | |
168 | ;; warnings may be silenced, since `place' is used earlier and | |
169 | ;; should have triggered them already. | |
170 | (with-no-warnings ,place) | |
171 | (setq ,place (cons x ,place)))) | |
6b34950f | 172 | (list 'setq place (list* 'adjoin x place keys))) |
fcd73769 RS |
173 | (list* 'callf2 'adjoin x place keys))) |
174 | ||
175 | (defun cl-set-elt (seq n val) | |
176 | (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) | |
177 | ||
4ded1ddb | 178 | (defsubst cl-set-nthcdr (n list x) |
fcd73769 RS |
179 | (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) |
180 | ||
181 | (defun cl-set-buffer-substring (start end val) | |
182 | (save-excursion (delete-region start end) | |
183 | (goto-char start) | |
184 | (insert val) | |
185 | val)) | |
186 | ||
187 | (defun cl-set-substring (str start end val) | |
188 | (if end (if (< end 0) (incf end (length str))) | |
189 | (setq end (length str))) | |
87dd507f | 190 | (if (< start 0) (incf start (length str))) |
fcd73769 RS |
191 | (concat (and (> start 0) (substring str 0 start)) |
192 | val | |
193 | (and (< end (length str)) (substring str end)))) | |
194 | ||
195 | ||
196 | ;;; Control structures. | |
197 | ||
b68f6e48 SM |
198 | ;; These macros are so simple and so often-used that it's better to have |
199 | ;; them all the time than to load them from cl-macs.el. | |
fcd73769 | 200 | |
fcd73769 | 201 | (defun cl-map-extents (&rest cl-args) |
f67171e6 | 202 | (apply 'cl-map-overlays cl-args)) |
fcd73769 RS |
203 | |
204 | ||
205 | ;;; Blocks and exits. | |
206 | ||
207 | (defalias 'cl-block-wrapper 'identity) | |
208 | (defalias 'cl-block-throw 'throw) | |
209 | ||
210 | ||
b68f6e48 SM |
211 | ;;; Multiple values. |
212 | ;; True multiple values are not supported, or even | |
213 | ;; simulated. Instead, multiple-value-bind and friends simply expect | |
214 | ;; the target form to return the values as a list. | |
fcd73769 | 215 | |
413da451 RS |
216 | (defsubst values (&rest values) |
217 | "Return multiple values, Common Lisp style. | |
218 | The arguments of `values' are the values | |
219 | that the containing function should return." | |
8f7ef366 | 220 | values) |
413da451 RS |
221 | |
222 | (defsubst values-list (list) | |
223 | "Return multiple values, Common Lisp style, taken from a list. | |
224 | LIST specifies the list of values | |
225 | that the containing function should return." | |
226 | list) | |
227 | ||
228 | (defsubst multiple-value-list (expression) | |
229 | "Return a list of the multiple values produced by EXPRESSION. | |
230 | This handles multiple values in Common Lisp style, but it does not | |
231 | work right when EXPRESSION calls an ordinary Emacs Lisp function | |
232 | that returns just one value." | |
233 | expression) | |
234 | ||
235 | (defsubst multiple-value-apply (function expression) | |
236 | "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. | |
237 | This handles multiple values in Common Lisp style, but it does not work | |
238 | right when EXPRESSION calls an ordinary Emacs Lisp function that returns just | |
239 | one value." | |
240 | (apply function expression)) | |
241 | ||
a2e74caa SM |
242 | (defalias 'multiple-value-call 'apply |
243 | "Apply FUNCTION to ARGUMENTS, taking multiple values into account. | |
244 | This implementation only handles the case where there is only one argument.") | |
f988b541 | 245 | |
413da451 RS |
246 | (defsubst nth-value (n expression) |
247 | "Evaluate EXPRESSION to get multiple values and return the Nth one. | |
248 | This handles multiple values in Common Lisp style, but it does not work | |
249 | right when EXPRESSION calls an ordinary Emacs Lisp function that returns just | |
250 | one value." | |
251 | (nth n expression)) | |
fcd73769 RS |
252 | |
253 | ;;; Macros. | |
254 | ||
7eb73deb | 255 | (defvar cl-macro-environment) |
fcd73769 RS |
256 | (defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand) |
257 | (defalias 'macroexpand 'cl-macroexpand))) | |
258 | ||
259 | (defun cl-macroexpand (cl-macro &optional cl-env) | |
2a8160e6 RS |
260 | "Return result of expanding macros at top level of FORM. |
261 | If FORM is not a macro call, it is returned unchanged. | |
262 | Otherwise, the macro is expanded and the expansion is considered | |
263 | in place of FORM. When a non-macro-call results, it is returned. | |
264 | ||
f15e298c | 265 | The second optional arg ENVIRONMENT specifies an environment of macro |
708c63a6 JB |
266 | definitions to shadow the loaded ones for use in file byte-compilation. |
267 | \n(fn FORM &optional ENVIRONMENT)" | |
fcd73769 RS |
268 | (let ((cl-macro-environment cl-env)) |
269 | (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) | |
270 | (and (symbolp cl-macro) | |
271 | (cdr (assq (symbol-name cl-macro) cl-env)))) | |
272 | (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) | |
273 | cl-macro)) | |
274 | ||
275 | ||
276 | ;;; Declarations. | |
277 | ||
278 | (defvar cl-compiling-file nil) | |
279 | (defun cl-compiling-file () | |
280 | (or cl-compiling-file | |
7200d79c SM |
281 | (and (boundp 'byte-compile--outbuffer) |
282 | (bufferp (symbol-value 'byte-compile--outbuffer)) | |
283 | (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) | |
fcd73769 RS |
284 | " *Compiler Output*")))) |
285 | ||
286 | (defvar cl-proclaims-deferred nil) | |
287 | ||
288 | (defun proclaim (spec) | |
289 | (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) | |
290 | (push spec cl-proclaims-deferred)) | |
291 | nil) | |
292 | ||
293 | (defmacro declaim (&rest specs) | |
294 | (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x)))) | |
295 | specs))) | |
296 | (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body) | |
297 | (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when | |
298 | ||
299 | ||
300 | ;;; Symbols. | |
301 | ||
302 | (defun cl-random-time () | |
303 | (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) | |
304 | (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) | |
305 | v)) | |
306 | ||
307 | (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) | |
308 | ||
309 | ||
310 | ;;; Numbers. | |
311 | ||
708c63a6 | 312 | (defun floatp-safe (object) |
f4db41fc | 313 | "Return t if OBJECT is a floating point number. |
fcd73769 RS |
314 | On Emacs versions that lack floating-point support, this function |
315 | always returns nil." | |
708c63a6 | 316 | (and (numberp object) (not (integerp object)))) |
fcd73769 | 317 | |
708c63a6 | 318 | (defun plusp (number) |
f4db41fc | 319 | "Return t if NUMBER is positive." |
708c63a6 | 320 | (> number 0)) |
fcd73769 | 321 | |
708c63a6 | 322 | (defun minusp (number) |
f4db41fc | 323 | "Return t if NUMBER is negative." |
708c63a6 | 324 | (< number 0)) |
fcd73769 | 325 | |
708c63a6 | 326 | (defun oddp (integer) |
f4db41fc | 327 | "Return t if INTEGER is odd." |
708c63a6 | 328 | (eq (logand integer 1) 1)) |
fcd73769 | 329 | |
708c63a6 | 330 | (defun evenp (integer) |
f4db41fc | 331 | "Return t if INTEGER is even." |
708c63a6 | 332 | (eq (logand integer 1) 0)) |
fcd73769 | 333 | |
fcd73769 RS |
334 | (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) |
335 | ||
416a2c45 GM |
336 | (defconst most-positive-float nil |
337 | "The largest value that a Lisp float can hold. | |
338 | If your system supports infinities, this is the largest finite value. | |
339 | For IEEE machines, this is approximately 1.79e+308. | |
340 | Call `cl-float-limits' to set this.") | |
341 | ||
342 | (defconst most-negative-float nil | |
343 | "The largest negative value that a Lisp float can hold. | |
44b0122f | 344 | This is simply -`most-positive-float'. |
416a2c45 GM |
345 | Call `cl-float-limits' to set this.") |
346 | ||
347 | (defconst least-positive-float nil | |
348 | "The smallest value greater than zero that a Lisp float can hold. | |
349 | For IEEE machines, it is about 4.94e-324 if denormals are supported, | |
350 | or 2.22e-308 if they are not. | |
351 | Call `cl-float-limits' to set this.") | |
352 | ||
353 | (defconst least-negative-float nil | |
354 | "The smallest value less than zero that a Lisp float can hold. | |
355 | This is simply -`least-positive-float'. | |
356 | Call `cl-float-limits' to set this.") | |
357 | ||
358 | (defconst least-positive-normalized-float nil | |
359 | "The smallest normalized Lisp float greater than zero. | |
360 | This is the smallest value for which IEEE denormalization does not lose | |
361 | precision. For IEEE machines, this value is about 2.22e-308. | |
362 | For machines that do not support the concept of denormalization | |
363 | and gradual underflow, this constant equals `least-positive-float'. | |
364 | Call `cl-float-limits' to set this.") | |
365 | ||
366 | (defconst least-negative-normalized-float nil | |
367 | "The smallest normalized Lisp float less than zero. | |
368 | This is simply -`least-positive-normalized-float'. | |
369 | Call `cl-float-limits' to set this.") | |
370 | ||
371 | (defconst float-epsilon nil | |
372 | "The smallest positive float that adds to 1.0 to give a distinct value. | |
373 | Adding a number less than this to 1.0 returns 1.0 due to roundoff. | |
374 | For IEEE machines, epsilon is about 2.22e-16. | |
375 | Call `cl-float-limits' to set this.") | |
376 | ||
377 | (defconst float-negative-epsilon nil | |
378 | "The smallest positive float that subtracts from 1.0 to give a distinct value. | |
379 | For IEEE machines, it is about 1.11e-16. | |
380 | Call `cl-float-limits' to set this.") | |
fcd73769 RS |
381 | |
382 | ||
383 | ;;; Sequence functions. | |
384 | ||
385 | (defalias 'copy-seq 'copy-sequence) | |
386 | ||
7467c796 GM |
387 | (declare-function cl-mapcar-many "cl-extra" (cl-func cl-seqs)) |
388 | ||
fcd73769 RS |
389 | (defun mapcar* (cl-func cl-x &rest cl-rest) |
390 | "Apply FUNCTION to each element of SEQ, and make a list of the results. | |
391 | If there are several SEQs, FUNCTION is called with that many arguments, | |
392 | and mapping stops as soon as the shortest list runs out. With just one | |
393 | SEQ, this is like `mapcar'. With several, it is like the Common Lisp | |
708c63a6 JB |
394 | `mapcar' function extended to arbitrary sequence types. |
395 | \n(fn FUNCTION SEQ...)" | |
fcd73769 RS |
396 | (if cl-rest |
397 | (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) | |
398 | (cl-mapcar-many cl-func (cons cl-x cl-rest)) | |
399 | (let ((cl-res nil) (cl-y (car cl-rest))) | |
400 | (while (and cl-x cl-y) | |
401 | (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) | |
402 | (nreverse cl-res))) | |
403 | (mapcar cl-func cl-x))) | |
404 | ||
686d0681 | 405 | (defalias 'svref 'aref) |
fcd73769 RS |
406 | |
407 | ;;; List functions. | |
408 | ||
409 | (defalias 'first 'car) | |
dc79c3ea | 410 | (defalias 'second 'cadr) |
fcd73769 RS |
411 | (defalias 'rest 'cdr) |
412 | (defalias 'endp 'null) | |
413 | ||
dc79c3ea | 414 | (defun third (x) |
b7a90344 SM |
415 | "Return the third element of the list X." |
416 | (car (cdr (cdr x)))) | |
fcd73769 | 417 | |
dc79c3ea | 418 | (defun fourth (x) |
b7a90344 SM |
419 | "Return the fourth element of the list X." |
420 | (nth 3 x)) | |
fcd73769 | 421 | |
dc79c3ea | 422 | (defun fifth (x) |
b7a90344 SM |
423 | "Return the fifth element of the list X." |
424 | (nth 4 x)) | |
fcd73769 | 425 | |
dc79c3ea | 426 | (defun sixth (x) |
b7a90344 SM |
427 | "Return the sixth element of the list X." |
428 | (nth 5 x)) | |
fcd73769 | 429 | |
dc79c3ea | 430 | (defun seventh (x) |
b7a90344 SM |
431 | "Return the seventh element of the list X." |
432 | (nth 6 x)) | |
fcd73769 | 433 | |
dc79c3ea | 434 | (defun eighth (x) |
b7a90344 SM |
435 | "Return the eighth element of the list X." |
436 | (nth 7 x)) | |
fcd73769 | 437 | |
dc79c3ea | 438 | (defun ninth (x) |
b7a90344 SM |
439 | "Return the ninth element of the list X." |
440 | (nth 8 x)) | |
fcd73769 | 441 | |
dc79c3ea | 442 | (defun tenth (x) |
b7a90344 SM |
443 | "Return the tenth element of the list X." |
444 | (nth 9 x)) | |
fcd73769 | 445 | |
fcd73769 RS |
446 | (defun caaar (x) |
447 | "Return the `car' of the `car' of the `car' of X." | |
448 | (car (car (car x)))) | |
449 | ||
450 | (defun caadr (x) | |
451 | "Return the `car' of the `car' of the `cdr' of X." | |
452 | (car (car (cdr x)))) | |
453 | ||
454 | (defun cadar (x) | |
455 | "Return the `car' of the `cdr' of the `car' of X." | |
456 | (car (cdr (car x)))) | |
457 | ||
458 | (defun caddr (x) | |
459 | "Return the `car' of the `cdr' of the `cdr' of X." | |
460 | (car (cdr (cdr x)))) | |
461 | ||
462 | (defun cdaar (x) | |
463 | "Return the `cdr' of the `car' of the `car' of X." | |
464 | (cdr (car (car x)))) | |
465 | ||
466 | (defun cdadr (x) | |
467 | "Return the `cdr' of the `car' of the `cdr' of X." | |
468 | (cdr (car (cdr x)))) | |
469 | ||
470 | (defun cddar (x) | |
471 | "Return the `cdr' of the `cdr' of the `car' of X." | |
472 | (cdr (cdr (car x)))) | |
473 | ||
474 | (defun cdddr (x) | |
475 | "Return the `cdr' of the `cdr' of the `cdr' of X." | |
476 | (cdr (cdr (cdr x)))) | |
477 | ||
478 | (defun caaaar (x) | |
479 | "Return the `car' of the `car' of the `car' of the `car' of X." | |
480 | (car (car (car (car x))))) | |
481 | ||
482 | (defun caaadr (x) | |
483 | "Return the `car' of the `car' of the `car' of the `cdr' of X." | |
484 | (car (car (car (cdr x))))) | |
485 | ||
486 | (defun caadar (x) | |
487 | "Return the `car' of the `car' of the `cdr' of the `car' of X." | |
488 | (car (car (cdr (car x))))) | |
489 | ||
490 | (defun caaddr (x) | |
491 | "Return the `car' of the `car' of the `cdr' of the `cdr' of X." | |
492 | (car (car (cdr (cdr x))))) | |
493 | ||
494 | (defun cadaar (x) | |
495 | "Return the `car' of the `cdr' of the `car' of the `car' of X." | |
496 | (car (cdr (car (car x))))) | |
497 | ||
498 | (defun cadadr (x) | |
499 | "Return the `car' of the `cdr' of the `car' of the `cdr' of X." | |
500 | (car (cdr (car (cdr x))))) | |
501 | ||
502 | (defun caddar (x) | |
503 | "Return the `car' of the `cdr' of the `cdr' of the `car' of X." | |
504 | (car (cdr (cdr (car x))))) | |
505 | ||
506 | (defun cadddr (x) | |
507 | "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." | |
508 | (car (cdr (cdr (cdr x))))) | |
509 | ||
510 | (defun cdaaar (x) | |
511 | "Return the `cdr' of the `car' of the `car' of the `car' of X." | |
512 | (cdr (car (car (car x))))) | |
513 | ||
514 | (defun cdaadr (x) | |
515 | "Return the `cdr' of the `car' of the `car' of the `cdr' of X." | |
516 | (cdr (car (car (cdr x))))) | |
517 | ||
518 | (defun cdadar (x) | |
519 | "Return the `cdr' of the `car' of the `cdr' of the `car' of X." | |
520 | (cdr (car (cdr (car x))))) | |
521 | ||
522 | (defun cdaddr (x) | |
523 | "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." | |
524 | (cdr (car (cdr (cdr x))))) | |
525 | ||
526 | (defun cddaar (x) | |
527 | "Return the `cdr' of the `cdr' of the `car' of the `car' of X." | |
528 | (cdr (cdr (car (car x))))) | |
529 | ||
530 | (defun cddadr (x) | |
531 | "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." | |
532 | (cdr (cdr (car (cdr x))))) | |
533 | ||
534 | (defun cdddar (x) | |
535 | "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." | |
536 | (cdr (cdr (cdr (car x))))) | |
537 | ||
538 | (defun cddddr (x) | |
539 | "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." | |
540 | (cdr (cdr (cdr (cdr x))))) | |
541 | ||
f9efebca RS |
542 | ;;(defun last* (x &optional n) |
543 | ;; "Returns the last link in the list LIST. | |
544 | ;;With optional argument N, returns Nth-to-last link (default 1)." | |
545 | ;; (if n | |
546 | ;; (let ((m 0) (p x)) | |
547 | ;; (while (consp p) (incf m) (pop p)) | |
548 | ;; (if (<= n 0) p | |
549 | ;; (if (< n m) (nthcdr (- m n) x) x))) | |
550 | ;; (while (consp (cdr x)) (pop x)) | |
551 | ;; x)) | |
fcd73769 | 552 | |
fcd73769 | 553 | (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el |
708c63a6 | 554 | "Return a new list with specified ARGs as elements, consed to last ARG. |
fcd73769 | 555 | Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to |
708c63a6 JB |
556 | `(cons A (cons B (cons C D)))'. |
557 | \n(fn ARG...)" | |
fcd73769 RS |
558 | (cond ((not rest) arg) |
559 | ((not (cdr rest)) (cons arg (car rest))) | |
560 | (t (let* ((n (length rest)) | |
561 | (copy (copy-sequence rest)) | |
562 | (last (nthcdr (- n 2) copy))) | |
563 | (setcdr last (car (cdr last))) | |
564 | (cons arg copy))))) | |
565 | ||
566 | (defun ldiff (list sublist) | |
567 | "Return a copy of LIST with the tail SUBLIST removed." | |
568 | (let ((res nil)) | |
569 | (while (and (consp list) (not (eq list sublist))) | |
570 | (push (pop list) res)) | |
571 | (nreverse res))) | |
572 | ||
6b25a2f5 | 573 | (defun copy-list (list) |
708c63a6 JB |
574 | "Return a copy of LIST, which may be a dotted list. |
575 | The elements of LIST are not copied, just the list structure itself." | |
6b25a2f5 RS |
576 | (if (consp list) |
577 | (let ((res nil)) | |
578 | (while (consp list) (push (pop list) res)) | |
579 | (prog1 (nreverse res) (setcdr res list))) | |
580 | (car list))) | |
581 | ||
fcd73769 RS |
582 | (defun cl-maclisp-member (item list) |
583 | (while (and list (not (equal item (car list)))) (setq list (cdr list))) | |
584 | list) | |
585 | ||
fcd73769 | 586 | (defalias 'cl-member 'memq) ; for compatibility with old CL package |
ec302593 GM |
587 | |
588 | ;; Autoloaded, but we have not loaded cl-loaddefs yet. | |
589 | (declare-function floor* "cl-extra" (x &optional y)) | |
590 | (declare-function ceiling* "cl-extra" (x &optional y)) | |
591 | (declare-function truncate* "cl-extra" (x &optional y)) | |
592 | (declare-function round* "cl-extra" (x &optional y)) | |
593 | (declare-function mod* "cl-extra" (x y)) | |
594 | ||
fcd73769 RS |
595 | (defalias 'cl-floor 'floor*) |
596 | (defalias 'cl-ceiling 'ceiling*) | |
597 | (defalias 'cl-truncate 'truncate*) | |
598 | (defalias 'cl-round 'round*) | |
599 | (defalias 'cl-mod 'mod*) | |
600 | ||
601 | (defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs | |
602 | "Return ITEM consed onto the front of LIST only if it's not already there. | |
603 | Otherwise, return LIST unmodified. | |
708c63a6 JB |
604 | \nKeywords supported: :test :test-not :key |
605 | \n(fn ITEM LIST [KEYWORD VALUE]...)" | |
fcd73769 RS |
606 | (cond ((or (equal cl-keys '(:test eq)) |
607 | (and (null cl-keys) (not (numberp cl-item)))) | |
608 | (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) | |
609 | ((or (equal cl-keys '(:test equal)) (null cl-keys)) | |
610 | (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) | |
611 | (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) | |
612 | ||
613 | (defun subst (cl-new cl-old cl-tree &rest cl-keys) | |
614 | "Substitute NEW for OLD everywhere in TREE (non-destructively). | |
615 | Return a copy of TREE with all elements `eql' to OLD replaced by NEW. | |
708c63a6 JB |
616 | \nKeywords supported: :test :test-not :key |
617 | \n(fn NEW OLD TREE [KEYWORD VALUE]...)" | |
fcd73769 RS |
618 | (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) |
619 | (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys) | |
620 | (cl-do-subst cl-new cl-old cl-tree))) | |
621 | ||
622 | (defun cl-do-subst (cl-new cl-old cl-tree) | |
623 | (cond ((eq cl-tree cl-old) cl-new) | |
624 | ((consp cl-tree) | |
625 | (let ((a (cl-do-subst cl-new cl-old (car cl-tree))) | |
626 | (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) | |
627 | (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) | |
628 | cl-tree (cons a d)))) | |
629 | (t cl-tree))) | |
630 | ||
868904eb JB |
631 | (defun acons (key value alist) |
632 | "Add KEY and VALUE to ALIST. | |
633 | Return a new list with (cons KEY VALUE) as car and ALIST as cdr." | |
634 | (cons (cons key value) alist)) | |
635 | ||
636 | (defun pairlis (keys values &optional alist) | |
637 | "Make an alist from KEYS and VALUES. | |
638 | Return a new alist composed by associating KEYS to corresponding VALUES; | |
639 | the process stops as soon as KEYS or VALUES run out. | |
640 | If ALIST is non-nil, the new pairs are prepended to it." | |
641 | (nconc (mapcar* 'cons keys values) alist)) | |
fcd73769 RS |
642 | |
643 | ||
644 | ;;; Miscellaneous. | |
645 | ||
b68f6e48 | 646 | ;; Define data for indentation and edebug. |
dbc65a5e SM |
647 | (dolist (entry |
648 | '(((defun* defmacro*) 2) | |
649 | ((function*) nil | |
650 | (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) | |
651 | ((eval-when) 1 (sexp &rest form)) | |
652 | ((declare) nil (&rest sexp)) | |
653 | ((the) 1 (sexp &rest form)) | |
654 | ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) | |
655 | ((block return-from) 1 (sexp &rest form)) | |
656 | ((return) nil (&optional form)) | |
657 | ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) | |
658 | (form &rest form) | |
659 | &rest form)) | |
660 | ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) | |
661 | ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) | |
662 | ((psetq setf psetf) nil edebug-setq-form) | |
663 | ((progv) 2 (&rest form)) | |
664 | ((flet labels macrolet) 1 | |
665 | ((&rest (sexp sexp &rest form)) &rest form)) | |
666 | ((symbol-macrolet lexical-let lexical-let*) 1 | |
667 | ((&rest &or symbolp (symbolp form)) &rest form)) | |
668 | ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) | |
669 | ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) | |
670 | ((incf decf remf pushnew shiftf rotatef) nil (&rest form)) | |
671 | ((letf letf*) 1 ((&rest (&rest form)) &rest form)) | |
672 | ((callf destructuring-bind) 2 (sexp form &rest form)) | |
673 | ((callf2) 3 (sexp form form &rest form)) | |
674 | ((loop) nil (&rest &or symbolp form)) | |
675 | ((ignore-errors) 0 (&rest form)))) | |
676 | (dolist (func (car entry)) | |
677 | (put func 'lisp-indent-function (nth 1 entry)) | |
678 | (put func 'lisp-indent-hook (nth 1 entry)) | |
679 | (or (get func 'edebug-form-spec) | |
680 | (put func 'edebug-form-spec (nth 2 entry))))) | |
fcd73769 | 681 | |
b68f6e48 SM |
682 | ;; Autoload the other portions of the package. |
683 | ;; We want to replace the basic versions of dolist, dotimes, declare below. | |
684 | (fmakunbound 'dolist) | |
685 | (fmakunbound 'dotimes) | |
686 | (fmakunbound 'declare) | |
1cd643e7 | 687 | (load "cl-loaddefs" nil 'quiet) |
fcd73769 | 688 | |
b68f6e48 | 689 | ;; This goes here so that cl-macs can find it if it loads right now. |
7467c796 | 690 | (provide 'cl) |
fcd73769 | 691 | |
b68f6e48 | 692 | ;; Things to do after byte-compiler is loaded. |
fcd73769 RS |
693 | |
694 | (defvar cl-hacked-flag nil) | |
695 | (defun cl-hack-byte-compiler () | |
7467c796 GM |
696 | (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form) |
697 | (progn | |
698 | (setq cl-hacked-flag t) ; Do it first, to prevent recursion. | |
699 | (load "cl-macs" nil t) | |
700 | (run-hooks 'cl-hack-bytecomp-hook)))) | |
fcd73769 | 701 | |
b68f6e48 | 702 | ;; Try it now in case the compiler has already been loaded. |
fcd73769 RS |
703 | (cl-hack-byte-compiler) |
704 | ||
b68f6e48 | 705 | ;; Also make a hook in case compiler is loaded after this file. |
0d752cda | 706 | (add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler) |
fcd73769 RS |
707 | |
708 | ||
b68f6e48 SM |
709 | ;; The following ensures that packages which expect the old-style cl.el |
710 | ;; will be happy with this one. | |
fcd73769 RS |
711 | |
712 | (provide 'cl) | |
713 | ||
fcd73769 RS |
714 | (run-hooks 'cl-load-hook) |
715 | ||
87787319 GM |
716 | ;; Local variables: |
717 | ;; byte-compile-dynamic: t | |
718 | ;; byte-compile-warnings: (not cl-functions) | |
719 | ;; End: | |
720 | ||
fcd73769 | 721 | ;;; cl.el ends here |