Line data Source code
1 : ;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 1993, 2000-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Dave Gillespie <daveg@synaptics.com>
6 : ;; Keywords: extensions
7 : ;; Package: emacs
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 3 of the License, or
14 : ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
23 :
24 : ;;; Commentary:
25 :
26 : ;; These are extensions to Emacs Lisp that provide a degree of
27 : ;; Common Lisp compatibility, beyond what is already built-in
28 : ;; in Emacs Lisp.
29 : ;;
30 : ;; This package was written by Dave Gillespie; it is a complete
31 : ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
32 : ;;
33 : ;; Bug reports, comments, and suggestions are welcome!
34 :
35 : ;; This file contains portions of the Common Lisp extensions
36 : ;; package which are autoloaded since they are relatively obscure.
37 :
38 : ;;; Code:
39 :
40 : (require 'cl-lib)
41 :
42 : ;;; Type coercion.
43 :
44 : ;;;###autoload
45 : (defun cl-coerce (x type)
46 : "Coerce OBJECT to type TYPE.
47 : TYPE is a Common Lisp type specifier.
48 : \n(fn OBJECT TYPE)"
49 1 : (cond ((eq type 'list) (if (listp x) x (append x nil)))
50 1 : ((eq type 'vector) (if (vectorp x) x (vconcat x)))
51 0 : ((eq type 'string) (if (stringp x) x (concat x)))
52 0 : ((eq type 'array) (if (arrayp x) x (vconcat x)))
53 0 : ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
54 0 : ((and (eq type 'character) (symbolp x))
55 0 : (cl-coerce (symbol-name x) type))
56 0 : ((eq type 'float) (float x))
57 0 : ((cl-typep x type) x)
58 1 : (t (error "Can't coerce %s to type %s" x type))))
59 :
60 :
61 : ;;; Predicates.
62 :
63 : ;;;###autoload
64 : (defun cl-equalp (x y)
65 : "Return t if two Lisp objects have similar structures and contents.
66 : This is like `equal', except that it accepts numerically equal
67 : numbers of different types (float vs. integer), and also compares
68 : strings case-insensitively."
69 0 : (cond ((eq x y) t)
70 0 : ((stringp x)
71 0 : (and (stringp y) (= (length x) (length y))
72 0 : (or (string-equal x y)
73 0 : (string-equal (downcase x) (downcase y))))) ;Lazy but simple!
74 0 : ((numberp x)
75 0 : (and (numberp y) (= x y)))
76 0 : ((consp x)
77 0 : (while (and (consp x) (consp y) (cl-equalp (car x) (car y)))
78 0 : (setq x (cdr x) y (cdr y)))
79 0 : (and (not (consp x)) (cl-equalp x y)))
80 0 : ((vectorp x)
81 0 : (and (vectorp y) (= (length x) (length y))
82 0 : (let ((i (length x)))
83 0 : (while (and (>= (setq i (1- i)) 0)
84 0 : (cl-equalp (aref x i) (aref y i))))
85 0 : (< i 0))))
86 0 : (t (equal x y))))
87 :
88 :
89 : ;;; Control structures.
90 :
91 : ;;;###autoload
92 : (defun cl--mapcar-many (cl-func cl-seqs &optional acc)
93 0 : (if (cdr (cdr cl-seqs))
94 0 : (let* ((cl-res nil)
95 0 : (cl-n (apply 'min (mapcar 'length cl-seqs)))
96 : (cl-i 0)
97 0 : (cl-args (copy-sequence cl-seqs))
98 : cl-p1 cl-p2)
99 0 : (setq cl-seqs (copy-sequence cl-seqs))
100 0 : (while (< cl-i cl-n)
101 0 : (setq cl-p1 cl-seqs cl-p2 cl-args)
102 0 : (while cl-p1
103 0 : (setcar cl-p2
104 0 : (if (consp (car cl-p1))
105 0 : (prog1 (car (car cl-p1))
106 0 : (setcar cl-p1 (cdr (car cl-p1))))
107 0 : (aref (car cl-p1) cl-i)))
108 0 : (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
109 0 : (if acc
110 0 : (push (apply cl-func cl-args) cl-res)
111 0 : (apply cl-func cl-args))
112 0 : (setq cl-i (1+ cl-i)))
113 0 : (and acc (nreverse cl-res)))
114 0 : (let ((cl-res nil)
115 0 : (cl-x (car cl-seqs))
116 0 : (cl-y (nth 1 cl-seqs)))
117 0 : (let ((cl-n (min (length cl-x) (length cl-y)))
118 : (cl-i -1))
119 0 : (while (< (setq cl-i (1+ cl-i)) cl-n)
120 0 : (let ((val (funcall cl-func
121 0 : (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
122 0 : (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))))
123 0 : (when acc
124 0 : (push val cl-res)))))
125 0 : (and acc (nreverse cl-res)))))
126 :
127 : ;;;###autoload
128 : (defun cl-map (cl-type cl-func cl-seq &rest cl-rest)
129 : "Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
130 : TYPE is the sequence type to return.
131 : \n(fn TYPE FUNCTION SEQUENCE...)"
132 0 : (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest)))
133 0 : (and cl-type (cl-coerce cl-res cl-type))))
134 :
135 : ;;;###autoload
136 : (defun cl-maplist (cl-func cl-list &rest cl-rest)
137 : "Map FUNCTION to each sublist of LIST or LISTs.
138 : Like `cl-mapcar', except applies to lists and their cdr's rather than to
139 : the elements themselves.
140 : \n(fn FUNCTION LIST...)"
141 0 : (if cl-rest
142 0 : (let ((cl-res nil)
143 0 : (cl-args (cons cl-list (copy-sequence cl-rest)))
144 : cl-p)
145 0 : (while (not (memq nil cl-args))
146 0 : (push (apply cl-func cl-args) cl-res)
147 0 : (setq cl-p cl-args)
148 0 : (while cl-p (setcar cl-p (cdr (pop cl-p)))))
149 0 : (nreverse cl-res))
150 0 : (let ((cl-res nil))
151 0 : (while cl-list
152 0 : (push (funcall cl-func cl-list) cl-res)
153 0 : (setq cl-list (cdr cl-list)))
154 0 : (nreverse cl-res))))
155 :
156 : ;;;###autoload
157 : (defun cl-mapc (cl-func cl-seq &rest cl-rest)
158 : "Like `cl-mapcar', but does not accumulate values returned by the function.
159 : \n(fn FUNCTION SEQUENCE...)"
160 0 : (if cl-rest
161 0 : (if (or (cdr cl-rest) (nlistp cl-seq) (nlistp (car cl-rest)))
162 0 : (progn
163 0 : (cl--mapcar-many cl-func (cons cl-seq cl-rest))
164 0 : cl-seq)
165 0 : (let ((cl-x cl-seq) (cl-y (car cl-rest)))
166 0 : (while (and cl-x cl-y)
167 0 : (funcall cl-func (pop cl-x) (pop cl-y)))
168 0 : cl-seq))
169 0 : (mapc cl-func cl-seq)))
170 :
171 : ;;;###autoload
172 : (defun cl-mapl (cl-func cl-list &rest cl-rest)
173 : "Like `cl-maplist', but does not accumulate values returned by the function.
174 : \n(fn FUNCTION LIST...)"
175 0 : (if cl-rest
176 0 : (let ((cl-args (cons cl-list (copy-sequence cl-rest)))
177 : cl-p)
178 0 : (while (not (memq nil cl-args))
179 0 : (apply cl-func cl-args)
180 0 : (setq cl-p cl-args)
181 0 : (while cl-p (setcar cl-p (cdr (pop cl-p))))))
182 0 : (let ((cl-p cl-list))
183 0 : (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
184 0 : cl-list)
185 :
186 : ;;;###autoload
187 : (defun cl-mapcan (cl-func cl-seq &rest cl-rest)
188 : "Like `cl-mapcar', but nconc's together the values returned by the function.
189 : \n(fn FUNCTION SEQUENCE...)"
190 0 : (if cl-rest
191 0 : (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))
192 0 : (mapcan cl-func cl-seq)))
193 :
194 : ;;;###autoload
195 : (defun cl-mapcon (cl-func cl-list &rest cl-rest)
196 : "Like `cl-maplist', but nconc's together the values returned by the function.
197 : \n(fn FUNCTION LIST...)"
198 0 : (apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest)))
199 :
200 : ;;;###autoload
201 : (defun cl-some (cl-pred cl-seq &rest cl-rest)
202 : "Return true if PREDICATE is true of any element of SEQ or SEQs.
203 : If so, return the true (non-nil) value returned by PREDICATE.
204 : \n(fn PREDICATE SEQ...)"
205 0 : (if (or cl-rest (nlistp cl-seq))
206 0 : (catch 'cl-some
207 0 : (apply 'cl-map nil
208 0 : (function (lambda (&rest cl-x)
209 0 : (let ((cl-res (apply cl-pred cl-x)))
210 0 : (if cl-res (throw 'cl-some cl-res)))))
211 0 : cl-seq cl-rest) nil)
212 0 : (let ((cl-x nil))
213 0 : (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
214 0 : cl-x)))
215 :
216 : ;;;###autoload
217 : (defun cl-every (cl-pred cl-seq &rest cl-rest)
218 : "Return true if PREDICATE is true of every element of SEQ or SEQs.
219 : \n(fn PREDICATE SEQ...)"
220 0 : (if (or cl-rest (nlistp cl-seq))
221 0 : (catch 'cl-every
222 0 : (apply 'cl-map nil
223 0 : (function (lambda (&rest cl-x)
224 0 : (or (apply cl-pred cl-x) (throw 'cl-every nil))))
225 0 : cl-seq cl-rest) t)
226 0 : (while (and cl-seq (funcall cl-pred (car cl-seq)))
227 0 : (setq cl-seq (cdr cl-seq)))
228 0 : (null cl-seq)))
229 :
230 : ;;;###autoload
231 : (defun cl-notany (cl-pred cl-seq &rest cl-rest)
232 : "Return true if PREDICATE is false of every element of SEQ or SEQs.
233 : \n(fn PREDICATE SEQ...)"
234 0 : (not (apply 'cl-some cl-pred cl-seq cl-rest)))
235 :
236 : ;;;###autoload
237 : (defun cl-notevery (cl-pred cl-seq &rest cl-rest)
238 : "Return true if PREDICATE is false of some element of SEQ or SEQs.
239 : \n(fn PREDICATE SEQ...)"
240 0 : (not (apply 'cl-every cl-pred cl-seq cl-rest)))
241 :
242 : ;;;###autoload
243 : (defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
244 0 : (or cl-base
245 0 : (setq cl-base (copy-sequence [0])))
246 0 : (map-keymap
247 0 : (function
248 : (lambda (cl-key cl-bind)
249 0 : (aset cl-base (1- (length cl-base)) cl-key)
250 0 : (if (keymapp cl-bind)
251 0 : (cl--map-keymap-recursively
252 0 : cl-func-rec cl-bind
253 0 : (vconcat cl-base (list 0)))
254 0 : (funcall cl-func-rec cl-base cl-bind))))
255 0 : cl-map))
256 :
257 : ;;;###autoload
258 : (defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
259 0 : (or cl-what (setq cl-what (current-buffer)))
260 0 : (if (bufferp cl-what)
261 0 : (let (cl-mark cl-mark2 (cl-next t) cl-next2)
262 0 : (with-current-buffer cl-what
263 0 : (setq cl-mark (copy-marker (or cl-start (point-min))))
264 0 : (setq cl-mark2 (and cl-end (copy-marker cl-end))))
265 0 : (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
266 0 : (setq cl-next (if cl-prop (next-single-property-change
267 0 : cl-mark cl-prop cl-what)
268 0 : (next-property-change cl-mark cl-what))
269 0 : cl-next2 (or cl-next (with-current-buffer cl-what
270 0 : (point-max))))
271 0 : (funcall cl-func (prog1 (marker-position cl-mark)
272 0 : (set-marker cl-mark cl-next2))
273 0 : (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
274 0 : (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
275 0 : (or cl-start (setq cl-start 0))
276 0 : (or cl-end (setq cl-end (length cl-what)))
277 0 : (while (< cl-start cl-end)
278 0 : (let ((cl-next (or (if cl-prop (next-single-property-change
279 0 : cl-start cl-prop cl-what)
280 0 : (next-property-change cl-start cl-what))
281 0 : cl-end)))
282 0 : (funcall cl-func cl-start (min cl-next cl-end))
283 0 : (setq cl-start cl-next)))))
284 :
285 : ;;;###autoload
286 : (defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
287 0 : (or cl-buffer (setq cl-buffer (current-buffer)))
288 0 : (let (cl-ovl)
289 0 : (with-current-buffer cl-buffer
290 0 : (setq cl-ovl (overlay-lists))
291 0 : (if cl-start (setq cl-start (copy-marker cl-start)))
292 0 : (if cl-end (setq cl-end (copy-marker cl-end))))
293 0 : (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
294 0 : (while (and cl-ovl
295 0 : (or (not (overlay-start (car cl-ovl)))
296 0 : (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
297 0 : (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
298 0 : (not (funcall cl-func (car cl-ovl) cl-arg))))
299 0 : (setq cl-ovl (cdr cl-ovl)))
300 0 : (if cl-start (set-marker cl-start nil))
301 0 : (if cl-end (set-marker cl-end nil))))
302 :
303 : ;;; Support for `setf'.
304 : ;;;###autoload
305 : (defun cl--set-frame-visible-p (frame val)
306 0 : (cond ((null val) (make-frame-invisible frame))
307 0 : ((eq val 'icon) (iconify-frame frame))
308 0 : (t (make-frame-visible frame)))
309 0 : val)
310 :
311 :
312 : ;;; Numbers.
313 :
314 : ;;;###autoload
315 : (defun cl-gcd (&rest args)
316 : "Return the greatest common divisor of the arguments."
317 0 : (let ((a (or (pop args) 0)))
318 0 : (dolist (b args)
319 0 : (while (/= b 0)
320 0 : (setq b (% a (setq a b)))))
321 0 : (abs a)))
322 :
323 : ;;;###autoload
324 : (defun cl-lcm (&rest args)
325 : "Return the least common multiple of the arguments."
326 0 : (if (memq 0 args)
327 : 0
328 0 : (let ((a (or (pop args) 1)))
329 0 : (dolist (b args)
330 0 : (setq a (* (/ a (cl-gcd a b)) b)))
331 0 : (abs a))))
332 :
333 : ;;;###autoload
334 : (defun cl-isqrt (x)
335 : "Return the integer square root of the argument."
336 0 : (if (and (integerp x) (> x 0))
337 0 : (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100)
338 0 : ((<= x 1000000) 1000) (t x)))
339 : g2)
340 0 : (while (< (setq g2 (/ (+ g (/ x g)) 2)) g)
341 0 : (setq g g2))
342 0 : g)
343 0 : (if (eq x 0) 0 (signal 'arith-error nil))))
344 :
345 : ;;;###autoload
346 : (defun cl-floor (x &optional y)
347 : "Return a list of the floor of X and the fractional part of X.
348 : With two arguments, return floor and remainder of their quotient."
349 0 : (let ((q (floor x y)))
350 0 : (list q (- x (if y (* y q) q)))))
351 :
352 : ;;;###autoload
353 : (defun cl-ceiling (x &optional y)
354 : "Return a list of the ceiling of X and the fractional part of X.
355 : With two arguments, return ceiling and remainder of their quotient."
356 0 : (let ((res (cl-floor x y)))
357 0 : (if (= (car (cdr res)) 0) res
358 0 : (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
359 :
360 : ;;;###autoload
361 : (defun cl-truncate (x &optional y)
362 : "Return a list of the integer part of X and the fractional part of X.
363 : With two arguments, return truncation and remainder of their quotient."
364 0 : (if (eq (>= x 0) (or (null y) (>= y 0)))
365 0 : (cl-floor x y) (cl-ceiling x y)))
366 :
367 : ;;;###autoload
368 : (defun cl-round (x &optional y)
369 : "Return a list of X rounded to the nearest integer and the remainder.
370 : With two arguments, return rounding and remainder of their quotient."
371 0 : (if y
372 0 : (if (and (integerp x) (integerp y))
373 0 : (let* ((hy (/ y 2))
374 0 : (res (cl-floor (+ x hy) y)))
375 0 : (if (and (= (car (cdr res)) 0)
376 0 : (= (+ hy hy) y)
377 0 : (/= (% (car res) 2) 0))
378 0 : (list (1- (car res)) hy)
379 0 : (list (car res) (- (car (cdr res)) hy))))
380 0 : (let ((q (round (/ x y))))
381 0 : (list q (- x (* q y)))))
382 0 : (if (integerp x) (list x 0)
383 0 : (let ((q (round x)))
384 0 : (list q (- x q))))))
385 :
386 : ;;;###autoload
387 : (defun cl-mod (x y)
388 : "The remainder of X divided by Y, with the same sign as Y."
389 0 : (nth 1 (cl-floor x y)))
390 :
391 : ;;;###autoload
392 : (defun cl-rem (x y)
393 : "The remainder of X divided by Y, with the same sign as X."
394 0 : (nth 1 (cl-truncate x y)))
395 :
396 : ;;;###autoload
397 : (defun cl-signum (x)
398 : "Return 1 if X is positive, -1 if negative, 0 if zero."
399 0 : (cond ((> x 0) 1) ((< x 0) -1) (t 0)))
400 :
401 : ;;;###autoload
402 : (cl-defun cl-parse-integer (string &key start end radix junk-allowed)
403 : "Parse integer from the substring of STRING from START to END.
404 : STRING may be surrounded by whitespace chars (chars with syntax ` ').
405 : Other non-digit chars are considered junk.
406 : RADIX is an integer between 2 and 36, the default is 10. Signal
407 : an error if the substring between START and END cannot be parsed
408 : as an integer unless JUNK-ALLOWED is non-nil."
409 0 : (cl-check-type string string)
410 0 : (let* ((start (or start 0))
411 0 : (len (length string))
412 0 : (end (or end len))
413 0 : (radix (or radix 10)))
414 0 : (or (<= start end len)
415 0 : (error "Bad interval: [%d, %d)" start end))
416 0 : (cl-flet ((skip-whitespace ()
417 0 : (while (and (< start end)
418 0 : (= 32 (char-syntax (aref string start))))
419 0 : (setq start (1+ start)))))
420 0 : (skip-whitespace)
421 0 : (let ((sign (cl-case (and (< start end) (aref string start))
422 0 : (?+ (cl-incf start) +1)
423 0 : (?- (cl-incf start) -1)
424 0 : (t +1)))
425 : digit sum)
426 0 : (while (and (< start end)
427 0 : (setq digit (cl-digit-char-p (aref string start) radix)))
428 0 : (setq sum (+ (* (or sum 0) radix) digit)
429 0 : start (1+ start)))
430 0 : (skip-whitespace)
431 0 : (cond ((and junk-allowed (null sum)) sum)
432 0 : (junk-allowed (* sign sum))
433 0 : ((or (/= start end) (null sum))
434 0 : (error "Not an integer string: `%s'" string))
435 0 : (t (* sign sum)))))))
436 :
437 :
438 : ;; Random numbers.
439 :
440 : (defun cl--random-time ()
441 0 : (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
442 0 : (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
443 0 : v))
444 :
445 : ;;;###autoload (autoload 'cl-random-state-p "cl-extra")
446 : (cl-defstruct (cl--random-state
447 : (:copier nil)
448 : (:predicate cl-random-state-p)
449 : (:constructor nil)
450 : (:constructor cl--make-random-state (vec)))
451 : (i -1) (j 30) vec)
452 :
453 : (defvar cl--random-state (cl--make-random-state (cl--random-time)))
454 :
455 : ;;;###autoload
456 : (defun cl-random (lim &optional state)
457 : "Return a random nonnegative number less than LIM, an integer or float.
458 : Optional second arg STATE is a random-state object."
459 0 : (or state (setq state cl--random-state))
460 : ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
461 0 : (let ((vec (cl--random-state-vec state)))
462 0 : (if (integerp vec)
463 0 : (let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1))
464 0 : (setf (cl--random-state-vec state)
465 0 : (setq vec (make-vector 55 nil)))
466 0 : (aset vec 0 j)
467 0 : (while (> (setq i (% (+ i 21) 55)) 0)
468 0 : (aset vec i (setq j (prog1 k (setq k (- j k))))))
469 0 : (while (< (setq i (1+ i)) 200) (cl-random 2 state))))
470 0 : (let* ((i (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-i state)))
471 0 : (j (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-j state)))
472 0 : (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
473 0 : (if (integerp lim)
474 0 : (if (<= lim 512) (% n lim)
475 0 : (if (> lim 8388607) (setq n (+ (lsh n 9) (cl-random 512 state))))
476 0 : (let ((mask 1023))
477 0 : (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
478 0 : (if (< (setq n (logand n mask)) lim) n (cl-random lim state))))
479 0 : (* (/ n '8388608e0) lim)))))
480 :
481 : ;;;###autoload
482 : (defun cl-make-random-state (&optional state)
483 : "Return a copy of random-state STATE, or of the internal state if omitted.
484 : If STATE is t, return a new state object seeded from the time of day."
485 0 : (unless state (setq state cl--random-state))
486 0 : (if (cl-random-state-p state)
487 0 : (copy-tree state t)
488 0 : (cl--make-random-state (if (integerp state) state (cl--random-time)))))
489 :
490 : ;; Implementation limits.
491 :
492 : (defun cl--finite-do (func a b)
493 0 : (condition-case _
494 0 : (let ((res (funcall func a b))) ; check for IEEE infinity
495 0 : (and (numberp res) (/= res (/ res 2)) res))
496 0 : (arith-error nil)))
497 :
498 : ;;;###autoload
499 : (defun cl-float-limits ()
500 : "Initialize the Common Lisp floating-point parameters.
501 : This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
502 : `cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon',
503 : `cl-float-negative-epsilon', `cl-least-positive-normalized-float', and
504 : `cl-least-negative-normalized-float'."
505 0 : (or cl-most-positive-float (not (numberp '2e1))
506 0 : (let ((x '2e0) y z)
507 : ;; Find maximum exponent (first two loops are optimizations)
508 0 : (while (cl--finite-do '* x x) (setq x (* x x)))
509 0 : (while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
510 0 : (while (cl--finite-do '+ x x) (setq x (+ x x)))
511 0 : (setq z x y (/ x 2))
512 : ;; Now cl-fill in 1's in the mantissa.
513 0 : (while (and (cl--finite-do '+ x y) (/= (+ x y) x))
514 0 : (setq x (+ x y) y (/ y 2)))
515 0 : (setq cl-most-positive-float x
516 0 : cl-most-negative-float (- x))
517 : ;; Divide down until mantissa starts rounding.
518 0 : (setq x (/ x z) y (/ 16 z) x (* x y))
519 0 : (while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
520 0 : (arith-error nil))
521 0 : (setq x (/ x 2) y (/ y 2)))
522 0 : (setq cl-least-positive-normalized-float y
523 0 : cl-least-negative-normalized-float (- y))
524 : ;; Divide down until value underflows to zero.
525 0 : (setq x (/ z) y x)
526 0 : (while (condition-case _ (> (/ x 2) 0) (arith-error nil))
527 0 : (setq x (/ x 2)))
528 0 : (setq cl-least-positive-float x
529 0 : cl-least-negative-float (- x))
530 0 : (setq x '1e0)
531 0 : (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
532 0 : (setq cl-float-epsilon (* x 2))
533 0 : (setq x '1e0)
534 0 : (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
535 0 : (setq cl-float-negative-epsilon (* x 2))))
536 : nil)
537 :
538 :
539 : ;;; Sequence functions.
540 :
541 : ;;;###autoload
542 : (defun cl-subseq (seq start &optional end)
543 : "Return the subsequence of SEQ from START to END.
544 : If END is omitted, it defaults to the length of the sequence.
545 : If START or END is negative, it counts from the end.
546 : Signal an error if START or END are outside of the sequence (i.e
547 : too large if positive or too small if negative)."
548 : (declare (gv-setter
549 : (lambda (new)
550 : (macroexp-let2 nil new new
551 : `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
552 : ,new)))))
553 2 : (cond ((or (stringp seq) (vectorp seq)) (substring seq start end))
554 2 : ((listp seq)
555 2 : (let (len
556 2 : (errtext (format "Bad bounding indices: %s, %s" start end)))
557 2 : (and end (< end 0) (setq end (+ end (setq len (length seq)))))
558 2 : (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
559 2 : (unless (>= start 0)
560 2 : (error "%s" errtext))
561 2 : (when (> start 0)
562 0 : (setq seq (nthcdr (1- start) seq))
563 0 : (or seq (error "%s" errtext))
564 2 : (setq seq (cdr seq)))
565 2 : (if end
566 2 : (let ((res nil))
567 24 : (while (and (>= (setq end (1- end)) start) seq)
568 44 : (push (pop seq) res))
569 2 : (or (= (1+ end) start) (error "%s" errtext))
570 2 : (nreverse res))
571 2 : (copy-sequence seq))))
572 2 : (t (error "Unsupported sequence: %s" seq))))
573 :
574 : ;;;###autoload
575 : (defun cl-concatenate (type &rest sequences)
576 : "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
577 : \n(fn TYPE SEQUENCE...)"
578 0 : (pcase type
579 0 : (`vector (apply #'vconcat sequences))
580 0 : (`string (apply #'concat sequences))
581 0 : (`list (apply #'append (append sequences '(nil))))
582 0 : (_ (error "Not a sequence type name: %S" type))))
583 :
584 : ;;; List functions.
585 :
586 : ;;;###autoload
587 : (defun cl-revappend (x y)
588 : "Equivalent to (append (reverse X) Y)."
589 0 : (nconc (reverse x) y))
590 :
591 : ;;;###autoload
592 : (defun cl-nreconc (x y)
593 : "Equivalent to (nconc (nreverse X) Y)."
594 0 : (nconc (nreverse x) y))
595 :
596 : ;;;###autoload
597 : (defun cl-list-length (x)
598 : "Return the length of list X. Return nil if list is circular."
599 0 : (let ((n 0) (fast x) (slow x))
600 0 : (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
601 0 : (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
602 0 : (if fast (if (cdr fast) nil (1+ n)) n)))
603 :
604 : ;;;###autoload
605 : (defun cl-tailp (sublist list)
606 : "Return true if SUBLIST is a tail of LIST."
607 0 : (while (and (consp list) (not (eq sublist list)))
608 0 : (setq list (cdr list)))
609 0 : (if (numberp sublist) (equal sublist list) (eq sublist list)))
610 :
611 : ;;; Property lists.
612 :
613 : ;;;###autoload
614 : (defun cl-get (sym tag &optional def)
615 : "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
616 : \n(fn SYMBOL PROPNAME &optional DEFAULT)"
617 : (declare (compiler-macro cl--compiler-macro-get)
618 : (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store))))
619 0 : (cl-getf (symbol-plist sym) tag def))
620 : (autoload 'cl--compiler-macro-get "cl-macs")
621 :
622 : ;;;###autoload
623 : (defun cl-getf (plist tag &optional def)
624 : "Search PROPLIST for property PROPNAME; return its value or DEFAULT.
625 : PROPLIST is a list of the sort returned by `symbol-plist'.
626 : \n(fn PROPLIST PROPNAME &optional DEFAULT)"
627 : (declare (gv-expander
628 : (lambda (do)
629 : (gv-letplace (getter setter) plist
630 : (macroexp-let2* nil ((k tag) (d def))
631 : (funcall do `(cl-getf ,getter ,k ,d)
632 : (lambda (v)
633 : (macroexp-let2 nil val v
634 : `(progn
635 : ,(funcall setter
636 : `(cl--set-getf ,getter ,k ,val))
637 : ,val)))))))))
638 0 : (let ((val-tail (cdr-safe (plist-member plist tag))))
639 0 : (if val-tail (car val-tail) def)))
640 :
641 : ;;;###autoload
642 : (defun cl--set-getf (plist tag val)
643 0 : (let ((val-tail (cdr-safe (plist-member plist tag))))
644 0 : (if val-tail (progn (setcar val-tail val) plist)
645 0 : (cl-list* tag val plist))))
646 :
647 : ;;;###autoload
648 : (defun cl--do-remf (plist tag)
649 0 : (let ((p (cdr plist)))
650 : ;; Can't use `plist-member' here because it goes to the cons-cell
651 : ;; of TAG and we need the one before.
652 0 : (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
653 0 : (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
654 :
655 : ;;;###autoload
656 : (defun cl-remprop (sym tag)
657 : "Remove from SYMBOL's plist the property PROPNAME and its value.
658 : \n(fn SYMBOL PROPNAME)"
659 0 : (let ((plist (symbol-plist sym)))
660 0 : (if (and plist (eq tag (car plist)))
661 0 : (progn (setplist sym (cdr (cdr plist))) t)
662 0 : (cl--do-remf plist tag))))
663 :
664 : ;;; Streams.
665 :
666 : ;;;###autoload
667 : (defun cl-fresh-line (&optional stream)
668 : "Output a newline unless already at the beginning of a line."
669 0 : (terpri stream 'ensure))
670 :
671 : ;;; Some debugging aids.
672 :
673 : (defun cl-prettyprint (form)
674 : "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
675 0 : (let ((pt (point)) last)
676 0 : (insert "\n" (prin1-to-string form) "\n")
677 0 : (setq last (point))
678 0 : (goto-char (1+ pt))
679 0 : (while (search-forward "(quote " last t)
680 0 : (delete-char -7)
681 0 : (insert "'")
682 0 : (forward-sexp)
683 0 : (delete-char 1))
684 0 : (goto-char (1+ pt))
685 0 : (cl--do-prettyprint)))
686 :
687 : (defun cl--do-prettyprint ()
688 0 : (skip-chars-forward " ")
689 0 : (if (looking-at "(")
690 0 : (let ((skip (or (looking-at "((") (looking-at "(prog")
691 0 : (looking-at "(unwind-protect ")
692 0 : (looking-at "(function (")
693 0 : (looking-at "(cl--block-wrapper ")))
694 0 : (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
695 0 : (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
696 0 : (set (looking-at "(p?set[qf] ")))
697 0 : (if (or skip let
698 0 : (progn
699 0 : (forward-sexp)
700 0 : (and (>= (current-column) 78) (progn (backward-sexp) t))))
701 0 : (let ((nl t))
702 0 : (forward-char 1)
703 0 : (cl--do-prettyprint)
704 0 : (or skip (looking-at ")") (cl--do-prettyprint))
705 0 : (or (not two) (looking-at ")") (cl--do-prettyprint))
706 0 : (while (not (looking-at ")"))
707 0 : (if set (setq nl (not nl)))
708 0 : (if nl (insert "\n"))
709 0 : (lisp-indent-line)
710 0 : (cl--do-prettyprint))
711 0 : (forward-char 1))))
712 0 : (forward-sexp)))
713 :
714 : ;;;###autoload
715 : (defun cl-prettyexpand (form &optional full)
716 : "Expand macros in FORM and insert the pretty-printed result.
717 : Optional argument FULL non-nil means to expand all macros,
718 : including `cl-block' and `cl-eval-when'."
719 0 : (message "Expanding...")
720 0 : (let ((cl--compiling-file full)
721 : (byte-compile-macro-environment nil))
722 0 : (setq form (macroexpand-all form
723 0 : (and (not full) '((cl-block) (cl-eval-when)))))
724 0 : (message "Formatting...")
725 0 : (prog1 (cl-prettyprint form)
726 0 : (message ""))))
727 :
728 : ;;; Integration into the online help system.
729 :
730 : (eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class.
731 : (require 'help-mode)
732 :
733 : ;; FIXME: We could go crazy and add another entry so describe-symbol can be
734 : ;; used with the slot names of CL structs (and/or EIEIO objects).
735 : (add-to-list 'describe-symbol-backends
736 : `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s))))
737 :
738 : (defconst cl--typedef-regexp
739 : (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct"
740 : "cl-deftype" "deftype"))
741 : "[ \t\r\n]+%s[ \t\r\n]+"))
742 : (with-eval-after-load 'find-func
743 : (defvar find-function-regexp-alist)
744 : (add-to-list 'find-function-regexp-alist
745 : `(define-type . cl--typedef-regexp)))
746 :
747 : (define-button-type 'cl-help-type
748 : :supertype 'help-function-def
749 : 'help-function #'cl-describe-type
750 : 'help-echo (purecopy "mouse-2, RET: describe this type"))
751 :
752 : (define-button-type 'cl-type-definition
753 : :supertype 'help-function-def
754 : 'help-echo (purecopy "mouse-2, RET: find type definition"))
755 :
756 : (declare-function help-fns-short-filename "help-fns" (filename))
757 :
758 : ;;;###autoload
759 0 : (defun cl-find-class (type) (cl--find-class type))
760 :
761 : ;;;###autoload
762 : (defun cl-describe-type (type)
763 : "Display the documentation for type TYPE (a symbol)."
764 : (interactive
765 0 : (let ((str (completing-read "Describe type: " obarray #'cl-find-class t)))
766 0 : (if (<= (length str) 0)
767 0 : (user-error "Abort!")
768 0 : (list (intern str)))))
769 0 : (help-setup-xref (list #'cl-describe-type type)
770 0 : (called-interactively-p 'interactive))
771 0 : (save-excursion
772 0 : (with-help-window (help-buffer)
773 0 : (with-current-buffer standard-output
774 0 : (let ((class (cl-find-class type)))
775 0 : (if class
776 0 : (cl--describe-class type class)
777 : ;; FIXME: Describe other types (the built-in ones, or those from
778 : ;; cl-deftype).
779 0 : (user-error "Unknown type %S" type))))
780 0 : (with-current-buffer standard-output
781 : ;; Return the text we displayed.
782 0 : (buffer-string)))))
783 :
784 : (defun cl--describe-class (type &optional class)
785 0 : (unless class (setq class (cl--find-class type)))
786 0 : (let ((location (find-lisp-object-file-name type 'define-type))
787 0 : (metatype (type-of class)))
788 0 : (insert (symbol-name type)
789 0 : (substitute-command-keys " is a type (of kind `"))
790 0 : (help-insert-xref-button (symbol-name metatype)
791 0 : 'cl-help-type metatype)
792 0 : (insert (substitute-command-keys "')"))
793 0 : (when location
794 0 : (insert (substitute-command-keys " in `"))
795 0 : (help-insert-xref-button
796 0 : (help-fns-short-filename location)
797 0 : 'cl-type-definition type location 'define-type)
798 0 : (insert (substitute-command-keys "'")))
799 0 : (insert ".\n")
800 :
801 : ;; Parents.
802 0 : (let ((pl (cl--class-parents class))
803 : cur)
804 0 : (when pl
805 0 : (insert " Inherits from ")
806 0 : (while (setq cur (pop pl))
807 0 : (setq cur (cl--class-name cur))
808 0 : (insert (substitute-command-keys "`"))
809 0 : (help-insert-xref-button (symbol-name cur)
810 0 : 'cl-help-type cur)
811 0 : (insert (substitute-command-keys (if pl "', " "'"))))
812 0 : (insert ".\n")))
813 :
814 : ;; Children, if available. ¡For EIEIO!
815 0 : (let ((ch (condition-case nil
816 0 : (cl-struct-slot-value metatype 'children class)
817 0 : (cl-struct-unknown-slot nil)))
818 : cur)
819 0 : (when ch
820 0 : (insert " Children ")
821 0 : (while (setq cur (pop ch))
822 0 : (insert (substitute-command-keys "`"))
823 0 : (help-insert-xref-button (symbol-name cur)
824 0 : 'cl-help-type cur)
825 0 : (insert (substitute-command-keys (if ch "', " "'"))))
826 0 : (insert ".\n")))
827 :
828 : ;; Type's documentation.
829 0 : (let ((doc (cl--class-docstring class)))
830 0 : (when doc
831 0 : (insert "\n" doc "\n\n")))
832 :
833 : ;; Describe all the slots in this class.
834 0 : (cl--describe-class-slots class)
835 :
836 : ;; Describe all the methods specific to this class.
837 0 : (let ((generics (cl-generic-all-functions type)))
838 0 : (when generics
839 0 : (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
840 0 : (dolist (generic generics)
841 0 : (insert (substitute-command-keys "`"))
842 0 : (help-insert-xref-button (symbol-name generic)
843 0 : 'help-function generic)
844 0 : (insert (substitute-command-keys "'"))
845 0 : (pcase-dolist (`(,qualifiers ,args ,doc)
846 0 : (cl--generic-method-documentation generic type))
847 0 : (insert (format " %s%S\n" qualifiers args)
848 0 : (or doc "")))
849 0 : (insert "\n\n"))))))
850 :
851 : (defun cl--describe-class-slot (slot)
852 0 : (insert
853 0 : (concat
854 0 : (propertize "Slot: " 'face 'bold)
855 0 : (prin1-to-string (cl--slot-descriptor-name slot))
856 0 : (unless (eq (cl--slot-descriptor-type slot) t)
857 0 : (concat " type = "
858 0 : (prin1-to-string (cl--slot-descriptor-type slot))))
859 : ;; FIXME: The default init form is treated differently for structs and for
860 : ;; eieio objects: for structs, the default is nil, for eieio-objects
861 : ;; it's a special "unbound" value.
862 0 : (unless nil ;; (eq (cl--slot-descriptor-initform slot) eieio-unbound)
863 0 : (concat " default = "
864 0 : (prin1-to-string (cl--slot-descriptor-initform slot))))
865 0 : (when (alist-get :printer (cl--slot-descriptor-props slot))
866 0 : (concat " printer = "
867 0 : (prin1-to-string
868 0 : (alist-get :printer (cl--slot-descriptor-props slot)))))
869 0 : (when (alist-get :documentation (cl--slot-descriptor-props slot))
870 0 : (concat "\n "
871 0 : (substitute-command-keys
872 0 : (alist-get :documentation (cl--slot-descriptor-props slot)))
873 0 : "\n")))
874 0 : "\n"))
875 :
876 : (defun cl--print-table (header rows)
877 : ;; FIXME: Isn't this functionality already implemented elsewhere?
878 0 : (let ((cols (apply #'vector (mapcar #'string-width header)))
879 : (col-space 2))
880 0 : (dolist (row rows)
881 0 : (dotimes (i (length cols))
882 0 : (let* ((x (pop row))
883 0 : (curwidth (aref cols i))
884 0 : (newwidth (if x (string-width x) 0)))
885 0 : (if (> newwidth curwidth)
886 0 : (setf (aref cols i) newwidth)))))
887 0 : (let ((formats '())
888 : (col 0))
889 0 : (dotimes (i (length cols))
890 0 : (push (concat (propertize " "
891 : 'display
892 0 : `(space :align-to ,(+ col col-space)))
893 0 : "%s")
894 0 : formats)
895 0 : (cl-incf col (+ col-space (aref cols i))))
896 0 : (let ((format (mapconcat #'identity (nreverse formats) "")))
897 0 : (insert (apply #'format format
898 0 : (mapcar (lambda (str) (propertize str 'face 'italic))
899 0 : header))
900 0 : "\n")
901 0 : (insert (apply #'format format
902 0 : (mapcar (lambda (str) (make-string (string-width str) ?—))
903 0 : header))
904 0 : "\n")
905 0 : (dolist (row rows)
906 0 : (insert (apply #'format format row) "\n"))))))
907 :
908 : (defun cl--describe-class-slots (class)
909 : "Print help description for the slots in CLASS.
910 : Outputs to the current buffer."
911 0 : (let* ((slots (cl--class-slots class))
912 0 : (metatype (type-of class))
913 : ;; ¡For EIEIO!
914 0 : (cslots (condition-case nil
915 0 : (cl-struct-slot-value metatype 'class-slots class)
916 0 : (cl-struct-unknown-slot nil))))
917 0 : (insert (propertize "Instance Allocated Slots:\n\n"
918 0 : 'face 'bold))
919 0 : (let* ((has-doc nil)
920 : (slots-strings
921 0 : (mapcar
922 : (lambda (slot)
923 0 : (list (cl-prin1-to-string (cl--slot-descriptor-name slot))
924 0 : (cl-prin1-to-string (cl--slot-descriptor-type slot))
925 0 : (cl-prin1-to-string (cl--slot-descriptor-initform slot))
926 0 : (let ((doc (alist-get :documentation
927 0 : (cl--slot-descriptor-props slot))))
928 0 : (if (not doc) ""
929 0 : (setq has-doc t)
930 0 : (substitute-command-keys doc)))))
931 0 : slots)))
932 0 : (cl--print-table `("Name" "Type" "Default" . ,(if has-doc '("Doc")))
933 0 : slots-strings))
934 0 : (insert "\n")
935 0 : (when (> (length cslots) 0)
936 0 : (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
937 0 : (mapc #'cl--describe-class-slot cslots))))
938 :
939 :
940 : (run-hooks 'cl-extra-load-hook)
941 :
942 : ;; Local variables:
943 : ;; byte-compile-dynamic: t
944 : ;; generated-autoload-file: "cl-loaddefs.el"
945 : ;; End:
946 :
947 : (provide 'cl-extra)
948 : ;;; cl-extra.el ends here
|