Comment change.
[bpt/emacs.git] / lisp / emacs-lisp / cl.el
CommitLineData
be010748 1;;; cl.el --- Common Lisp extensions for GNU Emacs Lisp
fcd73769
RS
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
7c938215 13;; the Free Software Foundation; either version 2, or (at your option)
fcd73769
RS
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
07b3798c 25;;; Commentary:
fcd73769
RS
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
07b3798c 42;;; Future notes:
fcd73769
RS
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
07b3798c 49;;; Change Log:
fcd73769
RS
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
07b3798c 95;;; Code:
fcd73769
RS
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.
131Each function is called in turn with three arguments: the object, the
132stream, and the print level (currently ignored). If it is able to
133print the object it returns true; otherwise it returns nil and the
134printer proceeds to the next function on the list.
135
136This variable is not used at present, but it is defined in hopes that
137a 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.
144Floating-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).
155PLACE may be a symbol, or any generalized variable allowed by `setf'.
156The 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).
163PLACE may be a symbol, or any generalized variable allowed by `setf'.
164The 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.
171Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more
172careful about evaluating each argument only once and in the right order.
173PLACE 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.
180Analogous to (setf PLACE (cons X PLACE)), though more careful about
181evaluating each argument only once and in the right order. PLACE may
182be 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.
188Like (push X PLACE), except that the list is unmodified if X is `eql' to
189an element already on the list.
190Keywords 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)
2a8160e6
RS
257 "Return result of expanding macros at top level of FORM.
258If FORM is not a macro call, it is returned unchanged.
259Otherwise, the macro is expanded and the expansion is considered
260in place of FORM. When a non-macro-call results, it is returned.
261
262The second optional arg ENVIRONMENT species an environment of macro
263definitions to shadow the loaded ones for use in file byte-compilation."
fcd73769
RS
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.
309On Emacs versions that lack floating-point support, this function
310always 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.
357If there are several SEQs, FUNCTION is called with that many arguments,
358and mapping stops as soon as the shortest list runs out. With just one
359SEQ, 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.
527With 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.
552Thus, `(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.
571The 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.
595Otherwise, return LIST unmodified.
596Keywords 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).
606Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
607Keywords 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.
633FUNC 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