Mercurial > emacs
annotate lisp/emacs-lisp/cl.el @ 11209:4d404c6112e3
Add missing close backquote.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Wed, 05 Apr 1995 20:46:40 +0000 |
parents | 6a9124f418db |
children | ac7375e60931 |
rev | line source |
---|---|
4355 | 1 ;; cl.el --- Common Lisp extensions for GNU Emacs Lisp |
2 | |
3 ;; Copyright (C) 1993 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 1, or (at your option) | |
14 ;; 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; see the file COPYING. If not, write to | |
23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
24 | |
7942 | 25 ;;; Commentary: |
4355 | 26 |
27 ;; These are extensions to Emacs Lisp that provide a degree of | |
28 ;; Common Lisp compatibility, beyond what is already built-in | |
29 ;; in Emacs Lisp. | |
30 ;; | |
31 ;; This package was written by Dave Gillespie; it is a complete | |
32 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | |
33 ;; | |
34 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. | |
35 ;; | |
36 ;; Bug reports, comments, and suggestions are welcome! | |
37 | |
38 ;; This file contains the portions of the Common Lisp extensions | |
39 ;; package which should always be present. | |
40 | |
41 | |
7942 | 42 ;;; Future notes: |
4355 | 43 |
44 ;; Once Emacs 19 becomes standard, many things in this package which are | |
45 ;; messy for reasons of compatibility can be greatly simplified. For now, | |
46 ;; I prefer to maintain one unified version. | |
47 | |
48 | |
7942 | 49 ;;; Change Log: |
4355 | 50 |
51 ;; Version 2.02 (30 Jul 93): | |
52 ;; * Added "cl-compat.el" file, extra compatibility with old package. | |
53 ;; * Added `lexical-let' and `lexical-let*'. | |
54 ;; * Added `define-modify-macro', `callf', and `callf2'. | |
55 ;; * Added `ignore-errors'. | |
56 ;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero. | |
57 ;; * Merged `*gentemp-counter*' into `*gensym-counter*'. | |
58 ;; * Extended `subseq' to allow negative START and END like `substring'. | |
59 ;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses. | |
60 ;; * Added `concat', `vconcat' loop clauses. | |
61 ;; * Cleaned up a number of compiler warnings. | |
62 | |
63 ;; Version 2.01 (7 Jul 93): | |
64 ;; * Added support for FSF version of Emacs 19. | |
65 ;; * Added `add-hook' for Emacs 18 users. | |
66 ;; * Added `defsubst*' and `symbol-macrolet'. | |
67 ;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'. | |
68 ;; * Added `map', `concatenate', `reduce', `merge'. | |
69 ;; * Added `revappend', `nreconc', `tailp', `tree-equal'. | |
70 ;; * Added `assert', `check-type', `typecase', `typep', and `deftype'. | |
71 ;; * Added destructuring and `&environment' support to `defmacro*'. | |
72 ;; * Added destructuring to `loop', and added the following clauses: | |
73 ;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'. | |
74 ;; * Renamed `delete' to `delete*' and `remove' to `remove*'. | |
75 ;; * Completed support for all keywords in `remove*', `substitute', etc. | |
76 ;; * Added `most-positive-float' and company. | |
77 ;; * Fixed hash tables to work with latest Lucid Emacs. | |
78 ;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'. | |
79 ;; * Syntax for `warn' declarations has changed. | |
80 ;; * Improved implementation of `random*'. | |
81 ;; * Moved most sequence functions to a new file, cl-seq.el. | |
82 ;; * Moved `eval-when' into cl-macs.el. | |
83 ;; * Moved `pushnew' and `adjoin' to cl.el for most common cases. | |
84 ;; * Moved `provide' forms down to ends of files. | |
85 ;; * Changed expansion of `pop' to something that compiles to better code. | |
86 ;; * Changed so that no patch is required for Emacs 19 byte compiler. | |
87 ;; * Made more things dependent on `optimize' declarations. | |
88 ;; * Added a partial implementation of struct print functions. | |
89 ;; * Miscellaneous minor changes. | |
90 | |
91 ;; Version 2.00: | |
92 ;; * First public release of this package. | |
93 | |
94 | |
7942 | 95 ;;; Code: |
4355 | 96 |
97 (defvar cl-emacs-type (cond ((or (and (fboundp 'epoch::version) | |
98 (symbol-value 'epoch::version)) | |
99 (string-lessp emacs-version "19")) 18) | |
100 ((string-match "Lucid" emacs-version) 'lucid) | |
101 (t 19))) | |
102 | |
103 (or (fboundp 'defalias) (fset 'defalias 'fset)) | |
104 | |
105 (defvar cl-optimize-speed 1) | |
106 (defvar cl-optimize-safety 1) | |
107 | |
108 | |
109 ;;; Keywords used in this package. | |
110 | |
111 (defconst :test ':test) | |
112 (defconst :test-not ':test-not) | |
113 (defconst :key ':key) | |
114 (defconst :start ':start) | |
115 (defconst :start1 ':start1) | |
116 (defconst :start2 ':start2) | |
117 (defconst :end ':end) | |
118 (defconst :end1 ':end1) | |
119 (defconst :end2 ':end2) | |
120 (defconst :count ':count) | |
121 (defconst :initial-value ':initial-value) | |
122 (defconst :size ':size) | |
123 (defconst :from-end ':from-end) | |
124 (defconst :rehash-size ':rehash-size) | |
125 (defconst :rehash-threshold ':rehash-threshold) | |
126 (defconst :allow-other-keys ':allow-other-keys) | |
127 | |
128 | |
129 (defvar custom-print-functions nil | |
130 "This is a list of functions that format user objects for printing. | |
131 Each function is called in turn with three arguments: the object, the | |
132 stream, and the print level (currently ignored). If it is able to | |
133 print the object it returns true; otherwise it returns nil and the | |
134 printer proceeds to the next function on the list. | |
135 | |
136 This variable is not used at present, but it is defined in hopes that | |
137 a future Emacs interpreter will be able to use it.") | |
138 | |
139 | |
140 ;;; Predicates. | |
141 | |
142 (defun eql (a b) ; See compiler macro in cl-macs.el | |
143 "T if the two args are the same Lisp object. | |
144 Floating-point numbers of equal value are `eql', but they may not be `eq'." | |
145 (if (numberp a) | |
146 (equal a b) | |
147 (eq a b))) | |
148 | |
149 | |
150 ;;; Generalized variables. These macros are defined here so that they | |
151 ;;; can safely be used in .emacs files. | |
152 | |
153 (defmacro incf (place &optional x) | |
154 "(incf PLACE [X]): increment PLACE by X (1 by default). | |
155 PLACE may be a symbol, or any generalized variable allowed by `setf'. | |
156 The return value is the incremented value of PLACE." | |
157 (if (symbolp place) | |
158 (list 'setq place (if x (list '+ place x) (list '1+ place))) | |
159 (list 'callf '+ place (or x 1)))) | |
160 | |
161 (defmacro decf (place &optional x) | |
162 "(decf PLACE [X]): decrement PLACE by X (1 by default). | |
163 PLACE may be a symbol, or any generalized variable allowed by `setf'. | |
164 The return value is the decremented value of PLACE." | |
165 (if (symbolp place) | |
166 (list 'setq place (if x (list '- place x) (list '1- place))) | |
167 (list 'callf '- place (or x 1)))) | |
168 | |
169 (defmacro pop (place) | |
170 "(pop PLACE): remove and return the head of the list stored in PLACE. | |
171 Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more | |
172 careful about evaluating each argument only once and in the right order. | |
173 PLACE may be a symbol, or any generalized variable allowed by `setf'." | |
174 (if (symbolp place) | |
175 (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) | |
176 (cl-do-pop place))) | |
177 | |
178 (defmacro push (x place) | |
179 "(push X PLACE): insert X at the head of the list stored in PLACE. | |
180 Analogous to (setf PLACE (cons X PLACE)), though more careful about | |
181 evaluating each argument only once and in the right order. PLACE may | |
182 be a symbol, or any generalized variable allowed by `setf'." | |
183 (if (symbolp place) (list 'setq place (list 'cons x place)) | |
184 (list 'callf2 'cons x place))) | |
185 | |
186 (defmacro pushnew (x place &rest keys) | |
187 "(pushnew X PLACE): insert X at the head of the list if not already there. | |
188 Like (push X PLACE), except that the list is unmodified if X is `eql' to | |
189 an element already on the list. | |
190 Keywords supported: :test :test-not :key" | |
191 (if (symbolp place) (list 'setq place (list* 'adjoin x place keys)) | |
192 (list* 'callf2 'adjoin x place keys))) | |
193 | |
194 (defun cl-set-elt (seq n val) | |
195 (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) | |
196 | |
197 (defun cl-set-nthcdr (n list x) | |
198 (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list)) | |
199 | |
200 (defun cl-set-buffer-substring (start end val) | |
201 (save-excursion (delete-region start end) | |
202 (goto-char start) | |
203 (insert val) | |
204 val)) | |
205 | |
206 (defun cl-set-substring (str start end val) | |
207 (if end (if (< end 0) (incf end (length str))) | |
208 (setq end (length str))) | |
209 (if (< start 0) (incf start str)) | |
210 (concat (and (> start 0) (substring str 0 start)) | |
211 val | |
212 (and (< end (length str)) (substring str end)))) | |
213 | |
214 | |
215 ;;; Control structures. | |
216 | |
217 ;;; These macros are so simple and so often-used that it's better to have | |
218 ;;; them all the time than to load them from cl-macs.el. | |
219 | |
220 (defmacro when (cond &rest body) | |
221 "(when COND BODY...): if COND yields non-nil, do BODY, else return nil." | |
222 (list 'if cond (cons 'progn body))) | |
223 | |
224 (defmacro unless (cond &rest body) | |
225 "(unless COND BODY...): if COND yields nil, do BODY, else return nil." | |
226 (cons 'if (cons cond (cons nil body)))) | |
227 | |
228 (defun cl-map-extents (&rest cl-args) | |
229 (if (fboundp 'next-overlay-at) (apply 'cl-map-overlays cl-args) | |
230 (if (fboundp 'map-extents) (apply 'map-extents cl-args)))) | |
231 | |
232 | |
233 ;;; Blocks and exits. | |
234 | |
235 (defalias 'cl-block-wrapper 'identity) | |
236 (defalias 'cl-block-throw 'throw) | |
237 | |
238 | |
239 ;;; Multiple values. True multiple values are not supported, or even | |
240 ;;; simulated. Instead, multiple-value-bind and friends simply expect | |
241 ;;; the target form to return the values as a list. | |
242 | |
243 (defalias 'values 'list) | |
244 (defalias 'values-list 'identity) | |
245 (defalias 'multiple-value-list 'identity) | |
246 (defalias 'multiple-value-call 'apply) ; only works for one arg | |
247 (defalias 'nth-value 'nth) | |
248 | |
249 | |
250 ;;; Macros. | |
251 | |
252 (defvar cl-macro-environment nil) | |
253 (defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand) | |
254 (defalias 'macroexpand 'cl-macroexpand))) | |
255 | |
256 (defun cl-macroexpand (cl-macro &optional cl-env) | |
9769
6a9124f418db
(cl-macroexpand): keep documentation from `macroexpand'.
Richard M. Stallman <rms@gnu.org>
parents:
7942
diff
changeset
|
257 "Return result of expanding macros at top level of FORM. |
6a9124f418db
(cl-macroexpand): keep documentation from `macroexpand'.
Richard M. Stallman <rms@gnu.org>
parents:
7942
diff
changeset
|
258 If FORM is not a macro call, it is returned unchanged. |
6a9124f418db
(cl-macroexpand): keep documentation from `macroexpand'.
Richard M. Stallman <rms@gnu.org>
parents:
7942
diff
changeset
|
259 Otherwise, the macro is expanded and the expansion is considered |
6a9124f418db
(cl-macroexpand): keep documentation from `macroexpand'.
Richard M. Stallman <rms@gnu.org>
parents:
7942
diff
changeset
|
260 in place of FORM. When a non-macro-call results, it is returned. |
6a9124f418db
(cl-macroexpand): keep documentation from `macroexpand'.
Richard M. Stallman <rms@gnu.org>
parents:
7942
diff
changeset
|
261 |
6a9124f418db
(cl-macroexpand): keep documentation from `macroexpand'.
Richard M. Stallman <rms@gnu.org>
parents:
7942
diff
changeset
|
262 The second optional arg ENVIRONMENT species an environment of macro |
6a9124f418db
(cl-macroexpand): keep documentation from `macroexpand'.
Richard M. Stallman <rms@gnu.org>
parents:
7942
diff
changeset
|
263 definitions to shadow the loaded ones for use in file byte-compilation." |
4355 | 264 (let ((cl-macro-environment cl-env)) |
265 (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) | |
266 (and (symbolp cl-macro) | |
267 (cdr (assq (symbol-name cl-macro) cl-env)))) | |
268 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) | |
269 cl-macro)) | |
270 | |
271 | |
272 ;;; Declarations. | |
273 | |
274 (defvar cl-compiling-file nil) | |
275 (defun cl-compiling-file () | |
276 (or cl-compiling-file | |
277 (and (boundp 'outbuffer) (bufferp (symbol-value 'outbuffer)) | |
278 (equal (buffer-name (symbol-value 'outbuffer)) | |
279 " *Compiler Output*")))) | |
280 | |
281 (defvar cl-proclaims-deferred nil) | |
282 | |
283 (defun proclaim (spec) | |
284 (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) | |
285 (push spec cl-proclaims-deferred)) | |
286 nil) | |
287 | |
288 (defmacro declaim (&rest specs) | |
289 (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x)))) | |
290 specs))) | |
291 (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body) | |
292 (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when | |
293 | |
294 | |
295 ;;; Symbols. | |
296 | |
297 (defun cl-random-time () | |
298 (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) | |
299 (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i)))) | |
300 v)) | |
301 | |
302 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) | |
303 | |
304 | |
305 ;;; Numbers. | |
306 | |
307 (defun floatp-safe (x) | |
308 "T if OBJECT is a floating point number. | |
309 On Emacs versions that lack floating-point support, this function | |
310 always returns nil." | |
311 (and (numberp x) (not (integerp x)))) | |
312 | |
313 (defun plusp (x) | |
314 "T if NUMBER is positive." | |
315 (> x 0)) | |
316 | |
317 (defun minusp (x) | |
318 "T if NUMBER is negative." | |
319 (< x 0)) | |
320 | |
321 (defun oddp (x) | |
322 "T if INTEGER is odd." | |
323 (eq (logand x 1) 1)) | |
324 | |
325 (defun evenp (x) | |
326 "T if INTEGER is even." | |
327 (eq (logand x 1) 0)) | |
328 | |
329 (defun cl-abs (x) | |
330 "Return the absolute value of ARG." | |
331 (if (>= x 0) x (- x))) | |
332 (or (fboundp 'abs) (defalias 'abs 'cl-abs)) ; This is built-in to Emacs 19 | |
333 | |
334 (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) | |
335 | |
336 ;;; We use `eval' in case VALBITS differs from compile-time to load-time. | |
337 (defconst most-positive-fixnum (eval '(lsh -1 -1))) | |
338 (defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1)))) | |
339 | |
340 ;;; The following are actually set by cl-float-limits. | |
341 (defconst most-positive-float nil) | |
342 (defconst most-negative-float nil) | |
343 (defconst least-positive-float nil) | |
344 (defconst least-negative-float nil) | |
345 (defconst least-positive-normalized-float nil) | |
346 (defconst least-negative-normalized-float nil) | |
347 (defconst float-epsilon nil) | |
348 (defconst float-negative-epsilon nil) | |
349 | |
350 | |
351 ;;; Sequence functions. | |
352 | |
353 (defalias 'copy-seq 'copy-sequence) | |
354 | |
355 (defun mapcar* (cl-func cl-x &rest cl-rest) | |
356 "Apply FUNCTION to each element of SEQ, and make a list of the results. | |
357 If there are several SEQs, FUNCTION is called with that many arguments, | |
358 and mapping stops as soon as the shortest list runs out. With just one | |
359 SEQ, this is like `mapcar'. With several, it is like the Common Lisp | |
360 `mapcar' function extended to arbitrary sequence types." | |
361 (if cl-rest | |
362 (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) | |
363 (cl-mapcar-many cl-func (cons cl-x cl-rest)) | |
364 (let ((cl-res nil) (cl-y (car cl-rest))) | |
365 (while (and cl-x cl-y) | |
366 (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) | |
367 (nreverse cl-res))) | |
368 (mapcar cl-func cl-x))) | |
369 | |
370 | |
371 ;;; List functions. | |
372 | |
373 (defalias 'first 'car) | |
374 (defalias 'rest 'cdr) | |
375 (defalias 'endp 'null) | |
376 | |
377 (defun second (x) | |
378 "Return the second element of the list LIST." | |
379 (car (cdr x))) | |
380 | |
381 (defun third (x) | |
382 "Return the third element of the list LIST." | |
383 (car (cdr (cdr x)))) | |
384 | |
385 (defun fourth (x) | |
386 "Return the fourth element of the list LIST." | |
387 (nth 3 x)) | |
388 | |
389 (defun fifth (x) | |
390 "Return the fifth element of the list LIST." | |
391 (nth 4 x)) | |
392 | |
393 (defun sixth (x) | |
394 "Return the sixth element of the list LIST." | |
395 (nth 5 x)) | |
396 | |
397 (defun seventh (x) | |
398 "Return the seventh element of the list LIST." | |
399 (nth 6 x)) | |
400 | |
401 (defun eighth (x) | |
402 "Return the eighth element of the list LIST." | |
403 (nth 7 x)) | |
404 | |
405 (defun ninth (x) | |
406 "Return the ninth element of the list LIST." | |
407 (nth 8 x)) | |
408 | |
409 (defun tenth (x) | |
410 "Return the tenth element of the list LIST." | |
411 (nth 9 x)) | |
412 | |
413 (defun caar (x) | |
414 "Return the `car' of the `car' of X." | |
415 (car (car x))) | |
416 | |
417 (defun cadr (x) | |
418 "Return the `car' of the `cdr' of X." | |
419 (car (cdr x))) | |
420 | |
421 (defun cdar (x) | |
422 "Return the `cdr' of the `car' of X." | |
423 (cdr (car x))) | |
424 | |
425 (defun cddr (x) | |
426 "Return the `cdr' of the `cdr' of X." | |
427 (cdr (cdr x))) | |
428 | |
429 (defun caaar (x) | |
430 "Return the `car' of the `car' of the `car' of X." | |
431 (car (car (car x)))) | |
432 | |
433 (defun caadr (x) | |
434 "Return the `car' of the `car' of the `cdr' of X." | |
435 (car (car (cdr x)))) | |
436 | |
437 (defun cadar (x) | |
438 "Return the `car' of the `cdr' of the `car' of X." | |
439 (car (cdr (car x)))) | |
440 | |
441 (defun caddr (x) | |
442 "Return the `car' of the `cdr' of the `cdr' of X." | |
443 (car (cdr (cdr x)))) | |
444 | |
445 (defun cdaar (x) | |
446 "Return the `cdr' of the `car' of the `car' of X." | |
447 (cdr (car (car x)))) | |
448 | |
449 (defun cdadr (x) | |
450 "Return the `cdr' of the `car' of the `cdr' of X." | |
451 (cdr (car (cdr x)))) | |
452 | |
453 (defun cddar (x) | |
454 "Return the `cdr' of the `cdr' of the `car' of X." | |
455 (cdr (cdr (car x)))) | |
456 | |
457 (defun cdddr (x) | |
458 "Return the `cdr' of the `cdr' of the `cdr' of X." | |
459 (cdr (cdr (cdr x)))) | |
460 | |
461 (defun caaaar (x) | |
462 "Return the `car' of the `car' of the `car' of the `car' of X." | |
463 (car (car (car (car x))))) | |
464 | |
465 (defun caaadr (x) | |
466 "Return the `car' of the `car' of the `car' of the `cdr' of X." | |
467 (car (car (car (cdr x))))) | |
468 | |
469 (defun caadar (x) | |
470 "Return the `car' of the `car' of the `cdr' of the `car' of X." | |
471 (car (car (cdr (car x))))) | |
472 | |
473 (defun caaddr (x) | |
474 "Return the `car' of the `car' of the `cdr' of the `cdr' of X." | |
475 (car (car (cdr (cdr x))))) | |
476 | |
477 (defun cadaar (x) | |
478 "Return the `car' of the `cdr' of the `car' of the `car' of X." | |
479 (car (cdr (car (car x))))) | |
480 | |
481 (defun cadadr (x) | |
482 "Return the `car' of the `cdr' of the `car' of the `cdr' of X." | |
483 (car (cdr (car (cdr x))))) | |
484 | |
485 (defun caddar (x) | |
486 "Return the `car' of the `cdr' of the `cdr' of the `car' of X." | |
487 (car (cdr (cdr (car x))))) | |
488 | |
489 (defun cadddr (x) | |
490 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." | |
491 (car (cdr (cdr (cdr x))))) | |
492 | |
493 (defun cdaaar (x) | |
494 "Return the `cdr' of the `car' of the `car' of the `car' of X." | |
495 (cdr (car (car (car x))))) | |
496 | |
497 (defun cdaadr (x) | |
498 "Return the `cdr' of the `car' of the `car' of the `cdr' of X." | |
499 (cdr (car (car (cdr x))))) | |
500 | |
501 (defun cdadar (x) | |
502 "Return the `cdr' of the `car' of the `cdr' of the `car' of X." | |
503 (cdr (car (cdr (car x))))) | |
504 | |
505 (defun cdaddr (x) | |
506 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." | |
507 (cdr (car (cdr (cdr x))))) | |
508 | |
509 (defun cddaar (x) | |
510 "Return the `cdr' of the `cdr' of the `car' of the `car' of X." | |
511 (cdr (cdr (car (car x))))) | |
512 | |
513 (defun cddadr (x) | |
514 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." | |
515 (cdr (cdr (car (cdr x))))) | |
516 | |
517 (defun cdddar (x) | |
518 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." | |
519 (cdr (cdr (cdr (car x))))) | |
520 | |
521 (defun cddddr (x) | |
522 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." | |
523 (cdr (cdr (cdr (cdr x))))) | |
524 | |
525 (defun last (x &optional n) | |
526 "Returns the last link in the list LIST. | |
527 With optional argument N, returns Nth-to-last link (default 1)." | |
528 (if n | |
529 (let ((m 0) (p x)) | |
530 (while (consp p) (incf m) (pop p)) | |
531 (if (<= n 0) p | |
532 (if (< n m) (nthcdr (- m n) x) x))) | |
533 (while (consp (cdr x)) (pop x)) | |
534 x)) | |
535 | |
536 (defun butlast (x &optional n) | |
537 "Returns a copy of LIST with the last N elements removed." | |
538 (if (and n (<= n 0)) x | |
539 (nbutlast (copy-sequence x) n))) | |
540 | |
541 (defun nbutlast (x &optional n) | |
542 "Modifies LIST to remove the last N elements." | |
543 (let ((m (length x))) | |
544 (or n (setq n 1)) | |
545 (and (< n m) | |
546 (progn | |
547 (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) | |
548 x)))) | |
549 | |
550 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el | |
551 "Return a new list with specified args as elements, cons'd to last arg. | |
552 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to | |
553 `(cons A (cons B (cons C D)))'." | |
554 (cond ((not rest) arg) | |
555 ((not (cdr rest)) (cons arg (car rest))) | |
556 (t (let* ((n (length rest)) | |
557 (copy (copy-sequence rest)) | |
558 (last (nthcdr (- n 2) copy))) | |
559 (setcdr last (car (cdr last))) | |
560 (cons arg copy))))) | |
561 | |
562 (defun 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 copy-list (list) | |
570 "Return a copy of a list, which may be a dotted list. | |
571 The elements of the 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 | |
582 ;;; Define an Emacs 19-compatible `member' for the benefit of Emacs 18 users. | |
583 (or (and (fboundp 'member) (subrp (symbol-function 'member))) | |
584 (defalias 'member 'cl-maclisp-member)) | |
585 | |
586 (defalias 'cl-member 'memq) ; for compatibility with old CL package | |
587 (defalias 'cl-floor 'floor*) | |
588 (defalias 'cl-ceiling 'ceiling*) | |
589 (defalias 'cl-truncate 'truncate*) | |
590 (defalias 'cl-round 'round*) | |
591 (defalias 'cl-mod 'mod*) | |
592 | |
593 (defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs | |
594 "Return ITEM consed onto the front of LIST only if it's not already there. | |
595 Otherwise, return LIST unmodified. | |
596 Keywords supported: :test :test-not :key" | |
597 (cond ((or (equal cl-keys '(:test eq)) | |
598 (and (null cl-keys) (not (numberp cl-item)))) | |
599 (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) | |
600 ((or (equal cl-keys '(:test equal)) (null cl-keys)) | |
601 (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) | |
602 (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) | |
603 | |
604 (defun subst (cl-new cl-old cl-tree &rest cl-keys) | |
605 "Substitute NEW for OLD everywhere in TREE (non-destructively). | |
606 Return a copy of TREE with all elements `eql' to OLD replaced by NEW. | |
607 Keywords supported: :test :test-not :key" | |
608 (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) | |
609 (apply '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 acons (a b c) (cons (cons a b) c)) | |
622 (defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c)) | |
623 | |
624 | |
625 ;;; Miscellaneous. | |
626 | |
627 (put 'cl-assertion-failed 'error-conditions '(error)) | |
628 (put 'cl-assertion-failed 'error-message "Assertion failed") | |
629 | |
630 ;;; This is defined in Emacs 19; define it here for Emacs 18 users. | |
631 (defun cl-add-hook (hook func &optional append) | |
632 "Add to hook variable HOOK the function FUNC. | |
633 FUNC is not added if it already appears on the list stored in HOOK." | |
634 (let ((old (and (boundp hook) (symbol-value hook)))) | |
635 (and (listp old) (not (eq (car old) 'lambda)) | |
636 (setq old (list old))) | |
637 (and (not (member func old)) | |
638 (set hook (if append (nconc old (list func)) (cons func old)))))) | |
639 (or (fboundp 'add-hook) (defalias 'add-hook 'cl-add-hook)) | |
640 | |
641 | |
642 ;;; Autoload the other portions of the package. | |
643 (mapcar (function | |
644 (lambda (set) | |
645 (mapcar (function | |
646 (lambda (func) | |
647 (autoload func (car set) nil nil (nth 1 set)))) | |
648 (cddr set)))) | |
649 '(("cl-extra" nil | |
650 coerce equalp cl-map-keymap maplist mapc mapl mapcan mapcon | |
651 cl-map-keymap cl-map-keymap-recursively cl-map-intervals | |
652 cl-map-overlays cl-set-frame-visible-p cl-float-limits | |
653 gcd lcm isqrt expt floor* ceiling* truncate* round* | |
654 mod* rem* signum random* make-random-state random-state-p | |
655 subseq concatenate cl-mapcar-many map some every notany | |
656 notevery revappend nreconc list-length tailp copy-tree get* getf | |
657 cl-set-getf cl-do-remf remprop make-hash-table cl-hash-lookup | |
658 gethash cl-puthash remhash clrhash maphash hash-table-p | |
659 hash-table-count cl-progv-before cl-prettyexpand | |
660 cl-macroexpand-all) | |
661 ("cl-seq" nil | |
662 reduce fill replace remq remove remove* remove-if remove-if-not | |
663 delete delete* delete-if delete-if-not remove-duplicates | |
664 delete-duplicates substitute substitute-if substitute-if-not | |
665 nsubstitute nsubstitute-if nsubstitute-if-not find find-if | |
666 find-if-not position position-if position-if-not count count-if | |
667 count-if-not mismatch search sort* stable-sort merge member* | |
668 member-if member-if-not cl-adjoin assoc* assoc-if assoc-if-not | |
669 rassoc* rassoc rassoc-if rassoc-if-not union nunion intersection | |
670 nintersection set-difference nset-difference set-exclusive-or | |
671 nset-exclusive-or subsetp subst-if subst-if-not nsubst nsubst-if | |
672 nsubst-if-not sublis nsublis tree-equal) | |
673 ("cl-macs" nil | |
674 gensym gentemp typep cl-do-pop get-setf-method | |
675 cl-struct-setf-expander compiler-macroexpand cl-compile-time-init) | |
676 ("cl-macs" t | |
677 defun* defmacro* function* destructuring-bind eval-when | |
678 eval-when-compile load-time-value case ecase typecase etypecase | |
679 block return return-from loop do do* dolist dotimes do-symbols | |
680 do-all-symbols psetq progv flet labels macrolet symbol-macrolet | |
681 lexical-let lexical-let* multiple-value-bind multiple-value-setq | |
682 locally the declare define-setf-method defsetf define-modify-macro | |
683 setf psetf remf shiftf rotatef letf letf* callf callf2 defstruct | |
684 check-type assert ignore-errors define-compiler-macro))) | |
685 | |
686 ;;; Define data for indentation and edebug. | |
687 (mapcar (function | |
688 (lambda (entry) | |
689 (mapcar (function | |
690 (lambda (func) | |
691 (put func 'lisp-indent-function (nth 1 entry)) | |
692 (put func 'lisp-indent-hook (nth 1 entry)) | |
693 (or (get func 'edebug-form-spec) | |
694 (put func 'edebug-form-spec (nth 2 entry))))) | |
695 (car entry)))) | |
696 '(((defun* defmacro*) 2) | |
697 ((function*) nil | |
698 (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) | |
699 ((eval-when) 1 (sexp &rest form)) | |
700 ((when unless) 1 (&rest form)) | |
701 ((declare) nil (&rest sexp)) | |
702 ((the) 1 (sexp &rest form)) | |
703 ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) | |
704 ((block return-from) 1 (sexp &rest form)) | |
705 ((return) nil (&optional form)) | |
706 ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) | |
707 (form &rest form) | |
708 &rest form)) | |
709 ((dolist dotimes) 1 ((symbolp form &rest form) &rest form)) | |
710 ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) | |
711 ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) | |
712 ((psetq setf psetf) nil edebug-setq-form) | |
713 ((progv) 2 (&rest form)) | |
714 ((flet labels macrolet) 1 | |
715 ((&rest (sexp sexp &rest form)) &rest form)) | |
716 ((symbol-macrolet lexical-let lexical-let*) 1 | |
717 ((&rest &or symbolp (symbolp form)) &rest form)) | |
718 ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) | |
719 ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) | |
720 ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form)) | |
721 ((letf letf*) 1 ((&rest (&rest form)) &rest form)) | |
722 ((callf destructuring-bind) 2 (sexp form &rest form)) | |
723 ((callf2) 3 (sexp form form &rest form)) | |
724 ((loop) nil (&rest &or symbolp form)) | |
725 ((ignore-errors) 0 (&rest form)))) | |
726 | |
727 | |
728 ;;; This goes here so that cl-macs can find it if it loads right now. | |
729 (provide 'cl-19) ; usage: (require 'cl-19 "cl") | |
730 | |
731 | |
732 ;;; Things to do after byte-compiler is loaded. | |
733 ;;; As a side effect, we cause cl-macs to be loaded when compiling, so | |
734 ;;; that the compiler-macros defined there will be present. | |
735 | |
736 (defvar cl-hacked-flag nil) | |
737 (defun cl-hack-byte-compiler () | |
738 (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)) | |
739 (progn | |
740 (cl-compile-time-init) ; in cl-macs.el | |
741 (setq cl-hacked-flag t)))) | |
742 | |
743 ;;; Try it now in case the compiler has already been loaded. | |
744 (cl-hack-byte-compiler) | |
745 | |
746 ;;; Also make a hook in case compiler is loaded after this file. | |
747 ;;; The compiler doesn't call any hooks when it loads or runs, but | |
748 ;;; we can take advantage of the fact that emacs-lisp-mode will be | |
749 ;;; called when the compiler reads in the file to be compiled. | |
750 ;;; BUG: If the first compilation is `byte-compile' rather than | |
751 ;;; `byte-compile-file', we lose. Oh, well. | |
752 (add-hook 'emacs-lisp-mode-hook 'cl-hack-byte-compiler) | |
753 | |
754 | |
755 ;;; The following ensures that packages which expect the old-style cl.el | |
756 ;;; will be happy with this one. | |
757 | |
758 (provide 'cl) | |
759 | |
760 (provide 'mini-cl) ; for Epoch | |
761 | |
762 (run-hooks 'cl-load-hook) | |
763 | |
764 ;;; cl.el ends here |