entered into RCS
[bpt/emacs.git] / lisp / emacs-lisp / cl-extra.el
CommitLineData
fcd73769
RS
1;; cl-extra.el --- Common Lisp extensions for GNU Emacs Lisp (part two)
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
25;; Commentary:
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 portions of the Common Lisp extensions
39;; package which are autoloaded since they are relatively obscure.
40
41;; See cl.el for Change Log.
42
43
44;; Code:
45
46(or (memq 'cl-19 features)
47 (error "Tried to load `cl-extra' before `cl'!"))
48
49
50;;; We define these here so that this file can compile without having
51;;; loaded the cl.el file already.
52
53(defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
54(defmacro cl-pop (place)
55 (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
56
57(defvar cl-emacs-type)
58
59
60;;; Type coercion.
61
62(defun coerce (x type)
63 "Coerce OBJECT to type TYPE.
64TYPE is a Common Lisp type specifier."
65 (cond ((eq type 'list) (if (listp x) x (append x nil)))
66 ((eq type 'vector) (if (vectorp x) x (vconcat x)))
67 ((eq type 'string) (if (stringp x) x (concat x)))
68 ((eq type 'array) (if (arrayp x) x (vconcat x)))
69 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
70 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
71 ((eq type 'float) (float x))
72 ((typep x type) x)
73 (t (error "Can't coerce %s to type %s" x type))))
74
75
76;;; Predicates.
77
78(defun equalp (x y)
79 "T if two Lisp objects have similar structures and contents.
80This is like `equal', except that it accepts numerically equal
81numbers of different types (float vs. integer), and also compares
82strings case-insensitively."
83 (cond ((eq x y) t)
84 ((stringp x)
85 (and (stringp y) (= (length x) (length y))
86 (or (equal x y)
87 (equal (downcase x) (downcase y))))) ; lazy but simple!
88 ((numberp x)
89 (and (numberp y) (= x y)))
90 ((consp x)
91 (while (and (consp x) (consp y) (equalp (cl-pop x) (cl-pop y))))
92 (and (not (consp x)) (equalp x y)))
93 ((vectorp x)
94 (and (vectorp y) (= (length x) (length y))
95 (let ((i (length x)))
96 (while (and (>= (setq i (1- i)) 0)
97 (equalp (aref x i) (aref y i))))
98 (< i 0))))
99 (t (equal x y))))
100
101
102;;; Control structures.
103
104(defun cl-mapcar-many (cl-func cl-seqs)
105 (if (cdr (cdr cl-seqs))
106 (let* ((cl-res nil)
107 (cl-n (apply 'min (mapcar 'length cl-seqs)))
108 (cl-i 0)
109 (cl-args (copy-sequence cl-seqs))
110 cl-p1 cl-p2)
111 (setq cl-seqs (copy-sequence cl-seqs))
112 (while (< cl-i cl-n)
113 (setq cl-p1 cl-seqs cl-p2 cl-args)
114 (while cl-p1
115 (setcar cl-p2
116 (if (consp (car cl-p1))
117 (prog1 (car (car cl-p1))
118 (setcar cl-p1 (cdr (car cl-p1))))
119 (aref (car cl-p1) cl-i)))
120 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
121 (cl-push (apply cl-func cl-args) cl-res)
122 (setq cl-i (1+ cl-i)))
123 (nreverse cl-res))
124 (let ((cl-res nil)
125 (cl-x (car cl-seqs))
126 (cl-y (nth 1 cl-seqs)))
127 (let ((cl-n (min (length cl-x) (length cl-y)))
128 (cl-i -1))
129 (while (< (setq cl-i (1+ cl-i)) cl-n)
130 (cl-push (funcall cl-func
131 (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i))
132 (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i)))
133 cl-res)))
134 (nreverse cl-res))))
135
136(defun map (cl-type cl-func cl-seq &rest cl-rest)
137 "Map a function across one or more sequences, returning a sequence.
138TYPE is the sequence type to return, FUNC is the function, and SEQS
139are the argument sequences."
140 (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
141 (and cl-type (coerce cl-res cl-type))))
142
143(defun maplist (cl-func cl-list &rest cl-rest)
144 "Map FUNC to each sublist of LIST or LISTS.
145Like `mapcar', except applies to lists and their cdr's rather than to
146the elements themselves."
147 (if cl-rest
148 (let ((cl-res nil)
149 (cl-args (cons cl-list (copy-sequence cl-rest)))
150 cl-p)
151 (while (not (memq nil cl-args))
152 (cl-push (apply cl-func cl-args) cl-res)
153 (setq cl-p cl-args)
154 (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) )))
155 (nreverse cl-res))
156 (let ((cl-res nil))
157 (while cl-list
158 (cl-push (funcall cl-func cl-list) cl-res)
159 (setq cl-list (cdr cl-list)))
160 (nreverse cl-res))))
161
162(defun mapc (cl-func cl-seq &rest cl-rest)
163 "Like `mapcar', but does not accumulate values returned by the function."
164 (if cl-rest
165 (apply 'map nil cl-func cl-seq cl-rest)
166 (mapcar cl-func cl-seq))
167 cl-seq)
168
169(defun mapl (cl-func cl-list &rest cl-rest)
170 "Like `maplist', but does not accumulate values returned by the function."
171 (if cl-rest
172 (apply 'maplist cl-func cl-list cl-rest)
173 (let ((cl-p cl-list))
174 (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
175 cl-list)
176
177(defun mapcan (cl-func cl-seq &rest cl-rest)
178 "Like `mapcar', but nconc's together the values returned by the function."
179 (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
180
181(defun mapcon (cl-func cl-list &rest cl-rest)
182 "Like `maplist', but nconc's together the values returned by the function."
183 (apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
184
185(defun some (cl-pred cl-seq &rest cl-rest)
186 "Return true if PREDICATE is true of any element of SEQ or SEQs.
187If so, return the true (non-nil) value returned by PREDICATE."
188 (if (or cl-rest (nlistp cl-seq))
189 (catch 'cl-some
190 (apply 'map nil
191 (function (lambda (&rest cl-x)
192 (let ((cl-res (apply cl-pred cl-x)))
193 (if cl-res (throw 'cl-some cl-res)))))
194 cl-seq cl-rest) nil)
195 (let ((cl-x nil))
196 (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq))))))
197 cl-x)))
198
199(defun every (cl-pred cl-seq &rest cl-rest)
200 "Return true if PREDICATE is true of every element of SEQ or SEQs."
201 (if (or cl-rest (nlistp cl-seq))
202 (catch 'cl-every
203 (apply 'map nil
204 (function (lambda (&rest cl-x)
205 (or (apply cl-pred cl-x) (throw 'cl-every nil))))
206 cl-seq cl-rest) t)
207 (while (and cl-seq (funcall cl-pred (car cl-seq)))
208 (setq cl-seq (cdr cl-seq)))
209 (null cl-seq)))
210
211(defun notany (cl-pred cl-seq &rest cl-rest)
212 "Return true if PREDICATE is false of every element of SEQ or SEQs."
213 (not (apply 'some cl-pred cl-seq cl-rest)))
214
215(defun notevery (cl-pred cl-seq &rest cl-rest)
216 "Return true if PREDICATE is false of some element of SEQ or SEQs."
217 (not (apply 'every cl-pred cl-seq cl-rest)))
218
219;;; Support for `loop'.
220(defun cl-map-keymap (cl-func cl-map)
221 (while (symbolp cl-map) (setq cl-map (symbol-function cl-map)))
222 (if (eq cl-emacs-type 'lucid) (funcall 'map-keymap cl-func cl-map)
223 (if (listp cl-map)
224 (let ((cl-p cl-map))
225 (while (consp (setq cl-p (cdr cl-p)))
226 (cond ((consp (car cl-p))
227 (funcall cl-func (car (car cl-p)) (cdr (car cl-p))))
228 ((vectorp (car cl-p))
229 (cl-map-keymap cl-func (car cl-p)))
230 ((eq (car cl-p) 'keymap)
231 (setq cl-p nil)))))
232 (let ((cl-i -1))
233 (while (< (setq cl-i (1+ cl-i)) (length cl-map))
234 (if (aref cl-map cl-i)
235 (funcall cl-func cl-i (aref cl-map cl-i))))))))
236
237(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
238 (or cl-base
239 (setq cl-base (copy-sequence (if (eq cl-emacs-type 18) "0" [0]))))
240 (cl-map-keymap
241 (function
242 (lambda (cl-key cl-bind)
243 (aset cl-base (1- (length cl-base)) cl-key)
244 (if (keymapp cl-bind)
245 (cl-map-keymap-recursively
246 cl-func-rec cl-bind
247 (funcall (if (eq cl-emacs-type 18) 'concat 'vconcat)
248 cl-base (list 0)))
249 (funcall cl-func-rec cl-base cl-bind))))
250 cl-map))
251
252(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
253 (or cl-what (setq cl-what (current-buffer)))
254 (if (bufferp cl-what)
255 (let (cl-mark cl-mark2 (cl-next t) cl-next2)
256 (save-excursion
257 (set-buffer cl-what)
258 (setq cl-mark (copy-marker (or cl-start (point-min))))
259 (setq cl-mark2 (and cl-end (copy-marker cl-end))))
260 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
261 (setq cl-next (and (fboundp 'next-property-change)
262 (if cl-prop (next-single-property-change
263 cl-mark cl-prop cl-what)
264 (next-property-change cl-mark cl-what)))
265 cl-next2 (or cl-next (save-excursion
266 (set-buffer cl-what) (point-max))))
267 (funcall cl-func (prog1 (marker-position cl-mark)
268 (set-marker cl-mark cl-next2))
269 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
270 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
271 (or cl-start (setq cl-start 0))
272 (or cl-end (setq cl-end (length cl-what)))
273 (while (< cl-start cl-end)
274 (let ((cl-next (or (and (fboundp 'next-property-change)
275 (if cl-prop (next-single-property-change
276 cl-start cl-prop cl-what)
277 (next-property-change cl-start cl-what)))
278 cl-end)))
279 (funcall cl-func cl-start (min cl-next cl-end))
280 (setq cl-start cl-next)))))
281
282(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
283 (or cl-buffer (setq cl-buffer (current-buffer)))
284 (if (fboundp 'overlay-lists)
285
286 ;; This is the preferred algorithm, though overlay-lists is undocumented.
287 (let (cl-ovl)
288 (save-excursion
289 (set-buffer cl-buffer)
290 (setq cl-ovl (overlay-lists))
291 (if cl-start (setq cl-start (copy-marker cl-start)))
292 (if cl-end (setq cl-end (copy-marker cl-end))))
293 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
294 (while (and cl-ovl
295 (or (not (overlay-start (car cl-ovl)))
296 (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
297 (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
298 (not (funcall cl-func (car cl-ovl) cl-arg))))
299 (setq cl-ovl (cdr cl-ovl)))
300 (if cl-start (set-marker cl-start nil))
301 (if cl-end (set-marker cl-end nil)))
302
303 ;; This alternate algorithm fails to find zero-length overlays.
304 (let ((cl-mark (save-excursion (set-buffer cl-buffer)
305 (copy-marker (or cl-start (point-min)))))
306 (cl-mark2 (and cl-end (save-excursion (set-buffer cl-buffer)
307 (copy-marker cl-end))))
308 cl-pos cl-ovl)
309 (while (save-excursion
310 (and (setq cl-pos (marker-position cl-mark))
311 (< cl-pos (or cl-mark2 (point-max)))
312 (progn
313 (set-buffer cl-buffer)
314 (setq cl-ovl (overlays-at cl-pos))
315 (set-marker cl-mark (next-overlay-change cl-pos)))))
316 (while (and cl-ovl
317 (or (/= (overlay-start (car cl-ovl)) cl-pos)
318 (not (and (funcall cl-func (car cl-ovl) cl-arg)
319 (set-marker cl-mark nil)))))
320 (setq cl-ovl (cdr cl-ovl))))
321 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
322
323;;; Support for `setf'.
324(defun cl-set-frame-visible-p (frame val)
325 (cond ((null val) (make-frame-invisible frame))
326 ((eq val 'icon) (iconify-frame frame))
327 (t (make-frame-visible frame)))
328 val)
329
330;;; Support for `progv'.
331(defvar cl-progv-save)
332(defun cl-progv-before (syms values)
333 (while syms
334 (cl-push (if (boundp (car syms))
335 (cons (car syms) (symbol-value (car syms)))
336 (car syms)) cl-progv-save)
337 (if values
338 (set (cl-pop syms) (cl-pop values))
339 (makunbound (cl-pop syms)))))
340
341(defun cl-progv-after ()
342 (while cl-progv-save
343 (if (consp (car cl-progv-save))
344 (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
345 (makunbound (car cl-progv-save)))
346 (cl-pop cl-progv-save)))
347
348
349;;; Numbers.
350
351(defun gcd (&rest args)
352 "Return the greatest common divisor of the arguments."
353 (let ((a (abs (or (cl-pop args) 0))))
354 (while args
355 (let ((b (abs (cl-pop args))))
356 (while (> b 0) (setq b (% a (setq a b))))))
357 a))
358
359(defun lcm (&rest args)
360 "Return the least common multiple of the arguments."
361 (if (memq 0 args)
362 0
363 (let ((a (abs (or (cl-pop args) 1))))
364 (while args
365 (let ((b (abs (cl-pop args))))
366 (setq a (* (/ a (gcd a b)) b))))
367 a)))
368
369(defun isqrt (a)
370 "Return the integer square root of the argument."
371 (if (and (integerp a) (> a 0))
372 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000)
373 ((>= a 100) 100) (t 10)))
374 g2)
375 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
376 (setq g g2))
377 g)
378 (if (eq a 0) 0 (signal 'arith-error nil))))
379
380(defun cl-expt (x y)
381 "Return X raised to the power of Y. Works only for integer arguments."
382 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) x 0))
383 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2)))))
384(or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
385 (defalias 'expt 'cl-expt))
386
387(defun floor* (x &optional y)
388 "Return a list of the floor of X and the fractional part of X.
389With two arguments, return floor and remainder of their quotient."
390 (if y
391 (if (and (integerp x) (integerp y))
392 (if (and (>= x 0) (>= y 0))
393 (list (/ x y) (% x y))
394 (let ((q (cond ((>= x 0) (- (/ (- x y 1) (- y))))
395 ((>= y 0) (- (/ (- y x 1) y)))
396 (t (/ (- x) (- y))))))
397 (list q (- x (* q y)))))
398 (let ((q (floor (/ x y))))
399 (list q (- x (* q y)))))
400 (if (integerp x) (list x 0)
401 (let ((q (floor x)))
402 (list q (- x q))))))
403
404(defun ceiling* (x &optional y)
405 "Return a list of the ceiling of X and the fractional part of X.
406With two arguments, return ceiling and remainder of their quotient."
407 (let ((res (floor* x y)))
408 (if (= (car (cdr res)) 0) res
409 (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
410
411(defun truncate* (x &optional y)
412 "Return a list of the integer part of X and the fractional part of X.
413With two arguments, return truncation and remainder of their quotient."
414 (if (eq (>= x 0) (or (null y) (>= y 0)))
415 (floor* x y) (ceiling* x y)))
416
417(defun round* (x &optional y)
418 "Return a list of X rounded to the nearest integer and the remainder.
419With two arguments, return rounding and remainder of their quotient."
420 (if y
421 (if (and (integerp x) (integerp y))
422 (let* ((hy (/ y 2))
423 (res (floor* (+ x hy) y)))
424 (if (and (= (car (cdr res)) 0)
425 (= (+ hy hy) y)
426 (/= (% (car res) 2) 0))
427 (list (1- (car res)) hy)
428 (list (car res) (- (car (cdr res)) hy))))
429 (let ((q (round (/ x y))))
430 (list q (- x (* q y)))))
431 (if (integerp x) (list x 0)
432 (let ((q (round x)))
433 (list q (- x q))))))
434
435(defun mod* (x y)
436 "The remainder of X divided by Y, with the same sign as Y."
437 (nth 1 (floor* x y)))
438
439(defun rem* (x y)
440 "The remainder of X divided by Y, with the same sign as X."
441 (nth 1 (truncate* x y)))
442
443(defun signum (a)
444 "Return 1 if A is positive, -1 if negative, 0 if zero."
445 (cond ((> a 0) 1) ((< a 0) -1) (t 0)))
446
447
448;; Random numbers.
449
450(defvar *random-state*)
451(defun random* (lim &optional state)
452 "Return a random nonnegative number less than LIM, an integer or float.
453Optional second arg STATE is a random-state object."
454 (or state (setq state *random-state*))
455 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
456 (let ((vec (aref state 3)))
457 (if (integerp vec)
458 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1) ii)
459 (aset state 3 (setq vec (make-vector 55 nil)))
460 (aset vec 0 j)
461 (while (> (setq i (% (+ i 21) 55)) 0)
462 (aset vec i (setq j (prog1 k (setq k (- j k))))))
463 (while (< (setq i (1+ i)) 200) (random* 2 state))))
464 (let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
465 (j (aset state 2 (% (1+ (aref state 2)) 55)))
466 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
467 (if (integerp lim)
468 (if (<= lim 512) (% n lim)
469 (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state))))
470 (let ((mask 1023))
471 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
472 (if (< (setq n (logand n mask)) lim) n (random* lim state))))
473 (* (/ n '8388608e0) lim)))))
474
475(defun make-random-state (&optional state)
476 "Return a copy of random-state STATE, or of `*random-state*' if omitted.
477If STATE is t, return a new state object seeded from the time of day."
478 (cond ((null state) (make-random-state *random-state*))
479 ((vectorp state) (cl-copy-tree state t))
480 ((integerp state) (vector 'cl-random-state-tag -1 30 state))
481 (t (make-random-state (cl-random-time)))))
482
483(defun random-state-p (object)
484 "Return t if OBJECT is a random-state object."
485 (and (vectorp object) (= (length object) 4)
486 (eq (aref object 0) 'cl-random-state-tag)))
487
488
489;; Implementation limits.
490
491(defun cl-finite-do (func a b)
492 (condition-case err
493 (let ((res (funcall func a b))) ; check for IEEE infinity
494 (and (numberp res) (/= res (/ res 2)) res))
495 (arith-error nil)))
496
497(defvar most-positive-float)
498(defvar most-negative-float)
499(defvar least-positive-float)
500(defvar least-negative-float)
501(defvar least-positive-normalized-float)
502(defvar least-negative-normalized-float)
503(defvar float-epsilon)
504(defvar float-negative-epsilon)
505
506(defun cl-float-limits ()
507 (or most-positive-float (not (numberp '2e1))
508 (let ((x '2e0) y z)
509 ;; Find maximum exponent (first two loops are optimizations)
510 (while (cl-finite-do '* x x) (setq x (* x x)))
511 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
512 (while (cl-finite-do '+ x x) (setq x (+ x x)))
513 (setq z x y (/ x 2))
514 ;; Now fill in 1's in the mantissa.
515 (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
516 (setq x (+ x y) y (/ y 2)))
517 (setq most-positive-float x
518 most-negative-float (- x))
519 ;; Divide down until mantissa starts rounding.
520 (setq x (/ x z) y (/ 16 z) x (* x y))
521 (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
522 (arith-error nil))
523 (setq x (/ x 2) y (/ y 2)))
524 (setq least-positive-normalized-float y
525 least-negative-normalized-float (- y))
526 ;; Divide down until value underflows to zero.
527 (setq x (/ 1 z) y x)
528 (while (condition-case err (> (/ x 2) 0) (arith-error nil))
529 (setq x (/ x 2)))
530 (setq least-positive-float x
531 least-negative-float (- x))
532 (setq x '1e0)
533 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
534 (setq float-epsilon (* x 2))
535 (setq x '1e0)
536 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
537 (setq float-negative-epsilon (* x 2))))
538 nil)
539
540
541;;; Sequence functions.
542
543(defun subseq (seq start &optional end)
544 "Return the subsequence of SEQ from START to END.
545If END is omitted, it defaults to the length of the sequence.
546If START or END is negative, it counts from the end."
547 (if (stringp seq) (substring seq start end)
548 (let (len)
549 (and end (< end 0) (setq end (+ end (setq len (length seq)))))
550 (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
551 (cond ((listp seq)
552 (if (> start 0) (setq seq (nthcdr start seq)))
553 (if end
554 (let ((res nil))
555 (while (>= (setq end (1- end)) start)
556 (cl-push (cl-pop seq) res))
557 (nreverse res))
558 (copy-sequence seq)))
559 (t
560 (or end (setq end (or len (length seq))))
561 (let ((res (make-vector (max (- end start) 0) nil))
562 (i 0))
563 (while (< start end)
564 (aset res i (aref seq start))
565 (setq i (1+ i) start (1+ start)))
566 res))))))
567
568(defun concatenate (type &rest seqs)
569 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES."
570 (cond ((eq type 'vector) (apply 'vconcat seqs))
571 ((eq type 'string) (apply 'concat seqs))
572 ((eq type 'list) (apply 'append (append seqs '(nil))))
573 (t (error "Not a sequence type name: %s" type))))
574
575
576;;; List functions.
577
578(defun revappend (x y)
579 "Equivalent to (append (reverse X) Y)."
580 (nconc (reverse x) y))
581
582(defun nreconc (x y)
583 "Equivalent to (nconc (nreverse X) Y)."
584 (nconc (nreverse x) y))
585
586(defun list-length (x)
587 "Return the length of a list. Return nil if list is circular."
588 (let ((n 0) (fast x) (slow x))
589 (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
590 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
591 (if fast (if (cdr fast) nil (1+ n)) n)))
592
593(defun tailp (sublist list)
594 "Return true if SUBLIST is a tail of LIST."
595 (while (and (consp list) (not (eq sublist list)))
596 (setq list (cdr list)))
597 (if (numberp sublist) (equal sublist list) (eq sublist list)))
598
599(defun cl-copy-tree (tree &optional vecp)
600 "Make a copy of TREE.
601If TREE is a cons cell, this recursively copies both its car and its cdr.
602Constrast to copy-sequence, which copies only along the cdrs. With second
603argument VECP, this copies vectors as well as conses."
604 (if (consp tree)
605 (let ((p (setq tree (copy-list tree))))
606 (while (consp p)
607 (if (or (consp (car p)) (and vecp (vectorp (car p))))
608 (setcar p (cl-copy-tree (car p) vecp)))
609 (or (listp (cdr p)) (setcdr p (cl-copy-tree (cdr p) vecp)))
610 (cl-pop p)))
611 (if (and vecp (vectorp tree))
612 (let ((i (length (setq tree (copy-sequence tree)))))
613 (while (>= (setq i (1- i)) 0)
614 (aset tree i (cl-copy-tree (aref tree i) vecp))))))
615 tree)
616(or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree)))
617 (defalias 'copy-tree 'cl-copy-tree))
618
619
620;;; Property lists.
621
622(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el
623 "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none."
624 (or (get sym tag)
625 (and def
626 (let ((plist (symbol-plist sym)))
627 (while (and plist (not (eq (car plist) tag)))
628 (setq plist (cdr (cdr plist))))
629 (if plist (car (cdr plist)) def)))))
630
631(defun getf (plist tag &optional def)
632 "Search PROPLIST for property PROPNAME; return its value or DEFAULT.
633PROPLIST is a list of the sort returned by `symbol-plist'."
634 (setplist '--cl-getf-symbol-- plist)
635 (or (get '--cl-getf-symbol-- tag)
636 (and def (get* '--cl-getf-symbol-- tag def))))
637
638(defun cl-set-getf (plist tag val)
639 (let ((p plist))
640 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
641 (if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
642
643(defun cl-do-remf (plist tag)
644 (let ((p (cdr plist)))
645 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
646 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
647
648(defun cl-remprop (sym tag)
649 "Remove from SYMBOL's plist the property PROP and its value."
650 (let ((plist (symbol-plist sym)))
651 (if (and plist (eq tag (car plist)))
652 (progn (setplist sym (cdr (cdr plist))) t)
653 (cl-do-remf plist tag))))
654(or (and (fboundp 'remprop) (subrp (symbol-function 'remprop)))
655 (defalias 'remprop 'cl-remprop))
656
657
658
659;;; Hash tables.
660
661(defun make-hash-table (&rest cl-keys)
662 "Make an empty Common Lisp-style hash-table.
663If :test is `eq', this can use Lucid Emacs built-in hash-tables.
664In non-Lucid Emacs, or with non-`eq' test, this internally uses a-lists.
665Keywords supported: :test :size
666The Common Lisp keywords :rehash-size and :rehash-threshold are ignored."
667 (let ((cl-test (or (car (cdr (memq ':test cl-keys))) 'eql))
668 (cl-size (or (car (cdr (memq ':size cl-keys))) 20)))
669 (if (and (eq cl-test 'eq) (fboundp 'make-hashtable))
670 (funcall 'make-hashtable cl-size)
671 (list 'cl-hash-table-tag cl-test
672 (if (> cl-size 1) (make-vector cl-size 0)
673 (let ((sym (make-symbol "--hashsym--"))) (set sym nil) sym))
674 0))))
675
676(defvar cl-lucid-hash-tag
677 (if (and (fboundp 'make-hashtable) (vectorp (make-hashtable 1)))
678 (aref (make-hashtable 1) 0) (make-symbol "--cl-hash-tag--")))
679
680(defun hash-table-p (x)
681 "Return t if OBJECT is a hash table."
682 (or (eq (car-safe x) 'cl-hash-table-tag)
683 (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag))
684 (and (fboundp 'hashtablep) (funcall 'hashtablep x))))
685
686(defun cl-not-hash-table (x &optional y &rest z)
687 (signal 'wrong-type-argument (list 'hash-table-p (or y x))))
688
689(defun cl-hash-lookup (key table)
690 (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table))
691 (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym)
692 (if (symbolp array) (setq str nil sym (symbol-value array))
693 (while (or (consp str) (and (vectorp str) (> (length str) 0)))
694 (setq str (elt str 0)))
695 (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str))))
696 ((symbolp str) (setq str (symbol-name str)))
697 ((and (numberp str) (> str -8000000) (< str 8000000))
698 (or (integerp str) (setq str (truncate str)))
699 (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10"
700 "11" "12" "13" "14" "15"] (logand str 15))))
701 (t (setq str "*")))
702 (setq sym (symbol-value (intern-soft str array))))
703 (list (and sym (cond ((or (eq test 'eq)
704 (and (eq test 'eql) (not (numberp key))))
705 (assq key sym))
706 ((memq test '(eql equal)) (assoc key sym))
707 (t (assoc* key sym ':test test))))
708 sym str)))
709
710(defvar cl-builtin-gethash
711 (if (and (fboundp 'gethash) (subrp (symbol-function 'gethash)))
712 (symbol-function 'gethash) 'cl-not-hash-table))
713(defvar cl-builtin-remhash
714 (if (and (fboundp 'remhash) (subrp (symbol-function 'remhash)))
715 (symbol-function 'remhash) 'cl-not-hash-table))
716(defvar cl-builtin-clrhash
717 (if (and (fboundp 'clrhash) (subrp (symbol-function 'clrhash)))
718 (symbol-function 'clrhash) 'cl-not-hash-table))
719(defvar cl-builtin-maphash
720 (if (and (fboundp 'maphash) (subrp (symbol-function 'maphash)))
721 (symbol-function 'maphash) 'cl-not-hash-table))
722
723(defun cl-gethash (key table &optional def)
724 "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT."
725 (if (consp table)
726 (let ((found (cl-hash-lookup key table)))
727 (if (car found) (cdr (car found)) def))
728 (funcall cl-builtin-gethash key table def)))
729(defalias 'gethash 'cl-gethash)
730
731(defun cl-puthash (key val table)
732 (if (consp table)
733 (let ((found (cl-hash-lookup key table)))
734 (if (car found) (setcdr (car found) val)
735 (if (nth 2 found)
736 (progn
737 (if (> (nth 3 table) (* (length (nth 2 table)) 3))
738 (let ((new-table (make-vector (nth 3 table) 0)))
739 (mapatoms (function
740 (lambda (sym)
741 (set (intern (symbol-name sym) new-table)
742 (symbol-value sym))))
743 (nth 2 table))
744 (setcar (cdr (cdr table)) new-table)))
745 (set (intern (nth 2 found) (nth 2 table))
746 (cons (cons key val) (nth 1 found))))
747 (set (nth 2 table) (cons (cons key val) (nth 1 found))))
748 (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table)))))
749 (funcall 'puthash key val table)) val)
750
751(defun cl-remhash (key table)
752 "Remove KEY from HASH-TABLE."
753 (if (consp table)
754 (let ((found (cl-hash-lookup key table)))
755 (and (car found)
756 (let ((del (delq (car found) (nth 1 found))))
757 (setcar (cdr (cdr (cdr table))) (1- (nth 3 table)))
758 (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del)
759 (set (nth 2 table) del)) t)))
760 (prog1 (not (eq (funcall cl-builtin-gethash key table '--cl--) '--cl--))
761 (funcall cl-builtin-remhash key table))))
762(defalias 'remhash 'cl-remhash)
763
764(defun cl-clrhash (table)
765 "Clear HASH-TABLE."
766 (if (consp table)
767 (progn
768 (or (hash-table-p table) (cl-not-hash-table table))
769 (if (symbolp (nth 2 table)) (set (nth 2 table) nil)
770 (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0)))
771 (setcar (cdr (cdr (cdr table))) 0))
772 (funcall cl-builtin-clrhash table))
773 nil)
774(defalias 'clrhash 'cl-clrhash)
775
776(defun cl-maphash (cl-func cl-table)
777 "Call FUNCTION on keys and values from HASH-TABLE."
778 (or (hash-table-p cl-table) (cl-not-hash-table cl-table))
779 (if (consp cl-table)
780 (mapatoms (function (lambda (cl-x)
781 (setq cl-x (symbol-value cl-x))
782 (while cl-x
783 (funcall cl-func (car (car cl-x))
784 (cdr (car cl-x)))
785 (setq cl-x (cdr cl-x)))))
786 (if (symbolp (nth 2 cl-table))
787 (vector (nth 2 cl-table)) (nth 2 cl-table)))
788 (funcall cl-builtin-maphash cl-func cl-table)))
789(defalias 'maphash 'cl-maphash)
790
791(defun hash-table-count (table)
792 "Return the number of entries in HASH-TABLE."
793 (or (hash-table-p table) (cl-not-hash-table table))
794 (if (consp table) (nth 3 table) (funcall 'hashtable-fullness table)))
795
796
797;;; Some debugging aids.
798
799(defun cl-prettyprint (form)
800 "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
801 (let ((pt (point)) last)
802 (insert "\n" (prin1-to-string form) "\n")
803 (setq last (point))
804 (goto-char (1+ pt))
805 (while (search-forward "(quote " last t)
806 (delete-backward-char 7)
807 (insert "'")
808 (forward-sexp)
809 (delete-char 1))
810 (goto-char (1+ pt))
811 (cl-do-prettyprint)))
812
813(defun cl-do-prettyprint ()
814 (skip-chars-forward " ")
815 (if (looking-at "(")
816 (let ((skip (or (looking-at "((") (looking-at "(prog")
817 (looking-at "(unwind-protect ")
818 (looking-at "(function (")
819 (looking-at "(cl-block-wrapper ")))
820 (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
821 (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
822 (set (looking-at "(p?set[qf] ")))
823 (if (or skip let
824 (progn
825 (forward-sexp)
826 (and (>= (current-column) 78) (progn (backward-sexp) t))))
827 (let ((nl t))
828 (forward-char 1)
829 (cl-do-prettyprint)
830 (or skip (looking-at ")") (cl-do-prettyprint))
831 (or (not two) (looking-at ")") (cl-do-prettyprint))
832 (while (not (looking-at ")"))
833 (if set (setq nl (not nl)))
834 (if nl (insert "\n"))
835 (lisp-indent-line)
836 (cl-do-prettyprint))
837 (forward-char 1))))
838 (forward-sexp)))
839
840(defvar cl-macroexpand-cmacs nil)
841(defvar cl-closure-vars nil)
842
843(defun cl-macroexpand-all (form &optional env)
844 "Expand all macro calls through a Lisp FORM.
845This also does some trivial optimizations to make the form prettier."
846 (while (or (not (eq form (setq form (macroexpand form env))))
847 (and cl-macroexpand-cmacs
848 (not (eq form (setq form (compiler-macroexpand form)))))))
849 (cond ((not (consp form)) form)
850 ((memq (car form) '(let let*))
851 (if (null (nth 1 form))
852 (cl-macroexpand-all (cons 'progn (cddr form)) env)
853 (let ((letf nil) (res nil) (lets (cadr form)))
854 (while lets
855 (cl-push (if (consp (car lets))
856 (let ((exp (cl-macroexpand-all (caar lets) env)))
857 (or (symbolp exp) (setq letf t))
858 (cons exp (cl-macroexpand-body (cdar lets) env)))
859 (let ((exp (cl-macroexpand-all (car lets) env)))
860 (if (symbolp exp) exp
861 (setq letf t) (list exp nil)))) res)
862 (setq lets (cdr lets)))
863 (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
864 (nreverse res) (cl-macroexpand-body (cddr form) env)))))
865 ((eq (car form) 'cond)
866 (cons (car form)
867 (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
868 (cdr form))))
869 ((eq (car form) 'condition-case)
870 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
871 (mapcar (function
872 (lambda (x)
873 (cons (car x) (cl-macroexpand-body (cdr x) env))))
874 (cdddr form))))
875 ((memq (car form) '(quote function))
876 (if (eq (car-safe (nth 1 form)) 'lambda)
877 (let ((body (cl-macroexpand-body (cddadr form) env)))
878 (if (and cl-closure-vars (eq (car form) 'function)
879 (cl-expr-contains-any body cl-closure-vars))
880 (let* ((new (mapcar 'gensym cl-closure-vars))
881 (sub (pairlis cl-closure-vars new)) (decls nil))
882 (while (or (stringp (car body))
883 (eq (car-safe (car body)) 'interactive))
884 (cl-push (list 'quote (cl-pop body)) decls))
885 (put (car (last cl-closure-vars)) 'used t)
886 (append
887 (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
888 (sublis sub (nreverse decls))
889 (list
890 (list* 'list '(quote apply)
891 (list 'list '(quote quote)
892 (list 'function
893 (list* 'lambda
894 (append new (cadadr form))
895 (sublis sub body))))
896 (nconc (mapcar (function
897 (lambda (x)
898 (list 'list '(quote quote) x)))
899 cl-closure-vars)
900 '((quote --cl-rest--)))))))
901 (list (car form) (list* 'lambda (cadadr form) body))))
902 form))
903 ((memq (car form) '(defun defmacro))
904 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
905 ((and (eq (car form) 'progn) (not (cddr form)))
906 (cl-macroexpand-all (nth 1 form) env))
907 ((eq (car form) 'setq)
908 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
909 (while (and p (symbolp (car p))) (setq p (cddr p)))
910 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
911 (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
912
913(defun cl-macroexpand-body (body &optional env)
914 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
915
916(defun cl-prettyexpand (form &optional full)
917 (message "Expanding...")
918 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
919 (byte-compile-macro-environment nil))
920 (setq form (cl-macroexpand-all form
921 (and (not full) '((block) (eval-when)))))
922 (message "Formatting...")
923 (prog1 (cl-prettyprint form)
924 (message ""))))
925
926
927
928(run-hooks 'cl-extra-load-hook)
929
930;;; cl-extra.el ends here