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