1 ;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*-
3 ;; Copyright (C) 1993, 2000-2018 Free Software Foundation, Inc.
5 ;; Author: Dave Gillespie <daveg@synaptics.com>
6 ;; Keywords: extensions
9 ;; This file is part of GNU Emacs.
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.
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
26 ;; These are extensions to Emacs Lisp that provide a degree of
27 ;; Common Lisp compatibility, beyond what is already built-in
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.
33 ;; Bug reports, comments, and suggestions are welcome!
35 ;; This file contains portions of the Common Lisp extensions
36 ;; package which are autoloaded since they are relatively obscure.
45 (defun cl-coerce (x type
)
46 "Coerce OBJECT to type TYPE.
47 TYPE is a Common Lisp type specifier.
49 (cond ((eq type
'list
) (if (listp x
) x
(append x nil
)))
50 ((eq type
'vector
) (if (vectorp x
) x
(vconcat x
)))
51 ((eq type
'string
) (if (stringp x
) x
(concat x
)))
52 ((eq type
'array
) (if (arrayp x
) x
(vconcat x
)))
53 ((and (eq type
'character
) (stringp x
) (= (length x
) 1)) (aref x
0))
54 ((and (eq type
'character
) (symbolp x
))
55 (cl-coerce (symbol-name x
) type
))
56 ((eq type
'float
) (float x
))
58 (t (error "Can't coerce %s to type %s" x type
))))
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."
71 (and (stringp y
) (= (length x
) (length y
))
72 (or (string-equal x y
)
73 (string-equal (downcase x
) (downcase y
))))) ;Lazy but simple!
75 (and (numberp y
) (= x y
)))
77 (while (and (consp x
) (consp y
) (cl-equalp (car x
) (car y
)))
78 (setq x
(cdr x
) y
(cdr y
)))
79 (and (not (consp x
)) (cl-equalp x y
)))
81 (and (vectorp y
) (= (length x
) (length y
))
83 (while (and (>= (setq i
(1- i
)) 0)
84 (cl-equalp (aref x i
) (aref y i
))))
89 ;;; Control structures.
92 (defun cl--mapcar-many (cl-func cl-seqs
&optional acc
)
93 (if (cdr (cdr cl-seqs
))
95 (cl-n (apply 'min
(mapcar 'length cl-seqs
)))
97 (cl-args (copy-sequence cl-seqs
))
99 (setq cl-seqs
(copy-sequence cl-seqs
))
101 (setq cl-p1 cl-seqs cl-p2 cl-args
)
104 (if (consp (car cl-p1
))
105 (prog1 (car (car cl-p1
))
106 (setcar cl-p1
(cdr (car cl-p1
))))
107 (aref (car cl-p1
) cl-i
)))
108 (setq cl-p1
(cdr cl-p1
) cl-p2
(cdr cl-p2
)))
110 (push (apply cl-func cl-args
) cl-res
)
111 (apply cl-func cl-args
))
112 (setq cl-i
(1+ cl-i
)))
113 (and acc
(nreverse cl-res
)))
116 (cl-y (nth 1 cl-seqs
)))
117 (let ((cl-n (min (length cl-x
) (length cl-y
)))
119 (while (< (setq cl-i
(1+ cl-i
)) cl-n
)
120 (let ((val (funcall cl-func
121 (if (consp cl-x
) (pop cl-x
) (aref cl-x cl-i
))
122 (if (consp cl-y
) (pop cl-y
) (aref cl-y cl-i
)))))
124 (push val cl-res
)))))
125 (and acc
(nreverse cl-res
)))))
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 (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest
)))
133 (and cl-type
(cl-coerce cl-res cl-type
))))
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...)"
143 (cl-args (cons cl-list
(copy-sequence cl-rest
)))
145 (while (not (memq nil cl-args
))
146 (push (apply cl-func cl-args
) cl-res
)
148 (while cl-p
(setcar cl-p
(cdr (pop cl-p
)))))
152 (push (funcall cl-func cl-list
) cl-res
)
153 (setq cl-list
(cdr cl-list
)))
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...)"
161 (if (or (cdr cl-rest
) (nlistp cl-seq
) (nlistp (car cl-rest
)))
163 (cl--mapcar-many cl-func
(cons cl-seq cl-rest
))
165 (let ((cl-x cl-seq
) (cl-y (car cl-rest
)))
166 (while (and cl-x cl-y
)
167 (funcall cl-func
(pop cl-x
) (pop cl-y
)))
169 (mapc cl-func cl-seq
)))
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...)"
176 (let ((cl-args (cons cl-list
(copy-sequence cl-rest
)))
178 (while (not (memq nil cl-args
))
179 (apply cl-func cl-args
)
181 (while cl-p
(setcar cl-p
(cdr (pop cl-p
))))))
182 (let ((cl-p cl-list
))
183 (while cl-p
(funcall cl-func cl-p
) (setq cl-p
(cdr cl-p
)))))
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...)"
191 (apply 'nconc
(apply 'cl-mapcar cl-func cl-seq cl-rest
))
192 (mapcan cl-func cl-seq
)))
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 (apply 'nconc
(apply 'cl-maplist cl-func cl-list cl-rest
)))
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 (if (or cl-rest
(nlistp cl-seq
))
208 (function (lambda (&rest cl-x
)
209 (let ((cl-res (apply cl-pred cl-x
)))
210 (if cl-res
(throw 'cl-some cl-res
)))))
213 (while (and cl-seq
(not (setq cl-x
(funcall cl-pred
(pop cl-seq
))))))
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 (if (or cl-rest
(nlistp cl-seq
))
223 (function (lambda (&rest cl-x
)
224 (or (apply cl-pred cl-x
) (throw 'cl-every nil
))))
226 (while (and cl-seq
(funcall cl-pred
(car cl-seq
)))
227 (setq cl-seq
(cdr cl-seq
)))
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 (not (apply 'cl-some cl-pred cl-seq cl-rest
)))
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 (not (apply 'cl-every cl-pred cl-seq cl-rest
)))
243 (defun cl--map-keymap-recursively (cl-func-rec cl-map
&optional cl-base
)
245 (setq cl-base
(copy-sequence [0])))
248 (lambda (cl-key cl-bind)
249 (aset cl-base (1- (length cl-base)) cl-key)
250 (if (keymapp cl-bind)
251 (cl--map-keymap-recursively
253 (vconcat cl-base (list 0)))
254 (funcall cl-func-rec cl-base cl-bind))))
258 (defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
259 (or cl-what (setq cl-what (current-buffer)))
260 (if (bufferp cl-what)
261 (let (cl-mark cl-mark2 (cl-next t) cl-next2)
262 (with-current-buffer cl-what
263 (setq cl-mark (copy-marker (or cl-start (point-min))))
264 (setq cl-mark2 (and cl-end (copy-marker cl-end))))
265 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
266 (setq cl-next (if cl-prop (next-single-property-change
267 cl-mark cl-prop cl-what)
268 (next-property-change cl-mark cl-what))
269 cl-next2 (or cl-next (with-current-buffer cl-what
271 (funcall cl-func (prog1 (marker-position cl-mark)
272 (set-marker cl-mark cl-next2))
273 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
274 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
275 (or cl-start (setq cl-start 0))
276 (or cl-end (setq cl-end (length cl-what)))
277 (while (< cl-start cl-end)
278 (let ((cl-next (or (if cl-prop (next-single-property-change
279 cl-start cl-prop cl-what)
280 (next-property-change cl-start cl-what))
282 (funcall cl-func cl-start (min cl-next cl-end))
283 (setq cl-start cl-next)))))
286 (defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
287 (or cl-buffer (setq cl-buffer (current-buffer)))
289 (with-current-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)))
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))))
303 ;;; Support for `setf'.
305 (defun cl--set-frame-visible-p (frame val)
306 (cond ((null val) (make-frame-invisible frame))
307 ((eq val 'icon) (iconify-frame frame))
308 (t (make-frame-visible frame)))
315 (defun cl-gcd (&rest args)
316 "Return the greatest common divisor of the arguments."
317 (let ((a (or (pop args) 0)))
320 (setq b (% a (setq a b)))))
324 (defun cl-lcm (&rest args)
325 "Return the least common multiple of the arguments."
328 (let ((a (or (pop args) 1)))
330 (setq a (* (/ a (cl-gcd a b)) b)))
335 "Return the integer square root of the argument."
336 (if (and (integerp x) (> x 0))
337 (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100)
338 ((<= x 1000000) 1000) (t x)))
340 (while (< (setq g2 (/ (+ g (/ x g)) 2)) g)
343 (if (eq x 0) 0 (signal 'arith-error nil))))
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 (let ((q (floor x y)))
350 (list q (- x (if y (* y q) q)))))
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 (let ((res (cl-floor x y)))
357 (if (= (car (cdr res)) 0) res
358 (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
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 (if (eq (>= x 0) (or (null y) (>= y 0)))
365 (cl-floor x y) (cl-ceiling x y)))
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."
372 (if (and (integerp x) (integerp y))
374 (res (cl-floor (+ x hy) y)))
375 (if (and (= (car (cdr res)) 0)
377 (/= (% (car res) 2) 0))
378 (list (1- (car res)) hy)
379 (list (car res) (- (car (cdr res)) hy))))
380 (let ((q (round (/ x y))))
381 (list q (- x (* q y)))))
382 (if (integerp x) (list x 0)
388 "The remainder of X divided by Y, with the same sign as Y."
389 (nth 1 (cl-floor x y)))
393 "The remainder of X divided by Y, with the same sign as X."
394 (nth 1 (cl-truncate x y)))
398 "Return 1 if X is positive, -1 if negative, 0 if zero."
399 (cond ((> x 0) 1) ((< x 0) -1) (t 0)))
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 (cl-check-type string string)
410 (let* ((start (or start 0))
411 (len (length string))
413 (radix (or radix 10)))
414 (or (<= start end len)
415 (error "Bad interval: [%d, %d)" start end))
416 (cl-flet ((skip-whitespace ()
417 (while (and (< start end)
418 (= 32 (char-syntax (aref string start))))
419 (setq start (1+ start)))))
421 (let ((sign (cl-case (and (< start end) (aref string start))
422 (?+ (cl-incf start) +1)
423 (?- (cl-incf start) -1)
426 (while (and (< start end)
427 (setq digit (cl-digit-char-p (aref string start) radix)))
428 (setq sum (+ (* (or sum 0) radix) digit)
431 (cond ((and junk-allowed (null sum)) sum)
432 (junk-allowed (* sign sum))
433 ((or (/= start end) (null sum))
434 (error "Not an integer string: `%s'" string))
435 (t (* sign sum)))))))
440 (defun cl--random-time ()
441 (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
442 (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
445 ;;;###autoload (autoload 'cl-random-state-p "cl-extra")
446 (cl-defstruct (cl--random-state
448 (:predicate cl-random-state-p)
450 (:constructor cl--make-random-state (vec)))
453 (defvar cl--random-state (cl--make-random-state (cl--random-time)))
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 (or state (setq state cl--random-state))
460 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
461 (let ((vec (cl--random-state-vec state)))
463 (let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1))
464 (setf (cl--random-state-vec state)
465 (setq vec (make-vector 55 nil)))
467 (while (> (setq i (% (+ i 21) 55)) 0)
468 (aset vec i (setq j (prog1 k (setq k (- j k))))))
469 (while (< (setq i (1+ i)) 200) (cl-random 2 state))))
470 (let* ((i (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-i state)))
471 (j (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-j state)))
472 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
474 (if (<= lim 512) (% n lim)
475 (if (> lim 8388607) (setq n (+ (lsh n 9) (cl-random 512 state))))
477 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
478 (if (< (setq n (logand n mask)) lim) n (cl-random lim state))))
479 (* (/ n '8388608e0) lim)))))
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 (unless state (setq state cl--random-state))
486 (if (cl-random-state-p state)
488 (cl--make-random-state (if (integerp state) state (cl--random-time)))))
490 ;; Implementation limits.
492 (defun cl--finite-do (func a b)
494 (let ((res (funcall func a b))) ; check for IEEE infinity
495 (and (numberp res) (/= res (/ res 2)) res))
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 (or cl-most-positive-float (not (numberp '2e1))
507 ;; Find maximum exponent (first two loops are optimizations)
508 (while (cl--finite-do '* x x) (setq x (* x x)))
509 (while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
510 (while (cl--finite-do '+ x x) (setq x (+ x x)))
512 ;; Now cl-fill in 1's in the mantissa.
513 (while (and (cl--finite-do '+ x y) (/= (+ x y) x))
514 (setq x (+ x y) y (/ y 2)))
515 (setq cl-most-positive-float x
516 cl-most-negative-float (- x))
517 ;; Divide down until mantissa starts rounding.
518 (setq x (/ x z) y (/ 16 z) x (* x y))
519 (while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
521 (setq x (/ x 2) y (/ y 2)))
522 (setq cl-least-positive-normalized-float y
523 cl-least-negative-normalized-float (- y))
524 ;; Divide down until value underflows to zero.
526 (while (condition-case _ (> (/ x 2) 0) (arith-error nil))
528 (setq cl-least-positive-float x
529 cl-least-negative-float (- x))
531 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
532 (setq cl-float-epsilon (* x 2))
534 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
535 (setq cl-float-negative-epsilon (* x 2))))
539 ;;; Sequence functions.
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)."
550 (macroexp-let2 nil new new
551 `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
553 (cond ((or (stringp seq) (vectorp seq)) (substring seq start end))
556 (errtext (format "Bad bounding indices: %s, %s" start end)))
557 (and end (< end 0) (setq end (+ end (setq len (length seq)))))
558 (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
560 (error "%s" errtext))
562 (setq seq (nthcdr (1- start) seq))
563 (or seq (error "%s" errtext))
564 (setq seq (cdr seq)))
567 (while (and (>= (setq end (1- end)) start) seq)
568 (push (pop seq) res))
569 (or (= (1+ end) start) (error "%s" errtext))
571 (copy-sequence seq))))
572 (t (error "Unsupported sequence: %s" seq))))
575 (defun cl-concatenate (type &rest sequences)
576 "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
577 \n(fn TYPE SEQUENCE...)"
579 (`vector (apply #'vconcat sequences))
580 (`string (apply #'concat sequences))
581 (`list (apply #'append (append sequences '(nil))))
582 (_ (error "Not a sequence type name: %S" type))))
587 (defun cl-revappend (x y)
588 "Equivalent to (append (reverse X) Y)."
589 (nconc (reverse x) y))
592 (defun cl-nreconc (x y)
593 "Equivalent to (nconc (nreverse X) Y)."
594 (nconc (nreverse x) y))
597 (defun cl-list-length (x)
598 "Return the length of list X. Return nil if list is circular."
599 (let ((n 0) (fast x) (slow x))
600 (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
601 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
602 (if fast (if (cdr fast) nil (1+ n)) n)))
605 (defun cl-tailp (sublist list)
606 "Return true if SUBLIST is a tail of LIST."
607 (while (and (consp list) (not (eq sublist list)))
608 (setq list (cdr list)))
609 (if (numberp sublist) (equal sublist list) (eq sublist list)))
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 (cl-getf (symbol-plist sym) tag def))
620 (autoload 'cl--compiler-macro-get "cl-macs")
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
629 (gv-letplace (getter setter) plist
630 (macroexp-let2* nil ((k tag) (d def))
631 (funcall do `(cl-getf ,getter ,k ,d)
633 (macroexp-let2 nil val v
636 `(cl--set-getf ,getter ,k ,val))
638 (let ((val-tail (cdr-safe (plist-member plist tag))))
639 (if val-tail (car val-tail) def)))
642 (defun cl--set-getf (plist tag val)
643 (let ((val-tail (cdr-safe (plist-member plist tag))))
644 (if val-tail (progn (setcar val-tail val) plist)
645 (cl-list* tag val plist))))
648 (defun cl--do-remf (plist tag)
649 (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 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
653 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
656 (defun cl-remprop (sym tag)
657 "Remove from SYMBOL's plist the property PROPNAME and its value.
658 \n(fn SYMBOL PROPNAME)"
659 (let ((plist (symbol-plist sym)))
660 (if (and plist (eq tag (car plist)))
661 (progn (setplist sym (cdr (cdr plist))) t)
662 (cl--do-remf plist tag))))
667 (defun cl-fresh-line (&optional stream)
668 "Output a newline unless already at the beginning of a line."
669 (terpri stream 'ensure))
671 ;;; Some debugging aids.
673 (defun cl-prettyprint (form)
674 "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
675 (let ((pt (point)) last)
676 (insert "\n" (prin1-to-string form) "\n")
679 (while (search-forward "(quote " last t)
685 (cl--do-prettyprint)))
687 (defun cl--do-prettyprint ()
688 (skip-chars-forward " ")
690 (let ((skip (or (looking-at "((") (looking-at "(prog")
691 (looking-at "(unwind-protect ")
692 (looking-at "(function (")
693 (looking-at "(cl--block-wrapper ")))
694 (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
695 (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
696 (set (looking-at "(p?set[qf] ")))
700 (and (>= (current-column) 78) (progn (backward-sexp) t))))
704 (or skip (looking-at ")") (cl--do-prettyprint))
705 (or (not two) (looking-at ")") (cl--do-prettyprint))
706 (while (not (looking-at ")"))
707 (if set (setq nl (not nl)))
708 (if nl (insert "\n"))
710 (cl--do-prettyprint))
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 (message "Expanding...")
720 (let ((cl--compiling-file full)
721 (byte-compile-macro-environment nil))
722 (setq form (macroexpand-all form
723 (and (not full) '((cl-block) (cl-eval-when)))))
724 (message "Formatting...")
725 (prog1 (cl-prettyprint form)
728 ;;; Integration into the online help system.
730 (eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class.
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))))
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)))
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"))
752 (define-button-type 'cl-type-definition
753 :supertype 'help-function-def
754 'help-echo (purecopy "mouse-2, RET: find type definition"))
756 (declare-function help-fns-short-filename "help-fns" (filename))
759 (defun cl-find-class (type) (cl--find-class type))
762 (defun cl-describe-type (type)
763 "Display the documentation for type TYPE (a symbol)."
765 (let ((str (completing-read "Describe type: " obarray #'cl-find-class t)))
766 (if (<= (length str) 0)
767 (user-error "Abort!")
768 (list (intern str)))))
769 (help-setup-xref (list #'cl-describe-type type)
770 (called-interactively-p 'interactive))
772 (with-help-window (help-buffer)
773 (with-current-buffer standard-output
774 (let ((class (cl-find-class type)))
776 (cl--describe-class type class)
777 ;; FIXME: Describe other types (the built-in ones, or those from
779 (user-error "Unknown type %S" type))))
780 (with-current-buffer standard-output
781 ;; Return the text we displayed.
784 (defun cl--describe-class (type &optional class)
785 (unless class (setq class (cl--find-class type)))
786 (let ((location (find-lisp-object-file-name type 'define-type))
787 (metatype (type-of class)))
788 (insert (symbol-name type)
789 (substitute-command-keys " is a type (of kind `"))
790 (help-insert-xref-button (symbol-name metatype)
791 'cl-help-type metatype)
792 (insert (substitute-command-keys "')"))
794 (insert (substitute-command-keys " in `"))
795 (help-insert-xref-button
796 (help-fns-short-filename location)
797 'cl-type-definition type location 'define-type)
798 (insert (substitute-command-keys "'")))
802 (let ((pl (cl--class-parents class))
805 (insert " Inherits from ")
806 (while (setq cur (pop pl))
807 (setq cur (cl--class-name cur))
808 (insert (substitute-command-keys "`"))
809 (help-insert-xref-button (symbol-name cur)
811 (insert (substitute-command-keys (if pl "', " "'"))))
814 ;; Children, if available. ¡For EIEIO!
815 (let ((ch (condition-case nil
816 (cl-struct-slot-value metatype 'children class)
817 (cl-struct-unknown-slot nil)))
820 (insert " Children ")
821 (while (setq cur (pop ch))
822 (insert (substitute-command-keys "`"))
823 (help-insert-xref-button (symbol-name cur)
825 (insert (substitute-command-keys (if ch "', " "'"))))
828 ;; Type's documentation.
829 (let ((doc (cl--class-docstring class)))
831 (insert "\n" doc "\n\n")))
833 ;; Describe all the slots in this class.
834 (cl--describe-class-slots class)
836 ;; Describe all the methods specific to this class.
837 (let ((generics (cl-generic-all-functions type)))
839 (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
840 (dolist (generic generics)
841 (insert (substitute-command-keys "`"))
842 (help-insert-xref-button (symbol-name generic)
843 'help-function generic)
844 (insert (substitute-command-keys "'"))
845 (pcase-dolist (`(,qualifiers ,args ,doc)
846 (cl--generic-method-documentation generic type))
847 (insert (format " %s%S\n" qualifiers args)
851 (defun cl--describe-class-slot (slot)
854 (propertize "Slot: " 'face 'bold)
855 (prin1-to-string (cl--slot-descriptor-name slot))
856 (unless (eq (cl--slot-descriptor-type slot) t)
858 (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 (unless nil ;; (eq (cl--slot-descriptor-initform slot) eieio-unbound)
863 (concat " default = "
864 (prin1-to-string (cl--slot-descriptor-initform slot))))
865 (when (alist-get :printer (cl--slot-descriptor-props slot))
866 (concat " printer = "
868 (alist-get :printer (cl--slot-descriptor-props slot)))))
869 (when (alist-get :documentation (cl--slot-descriptor-props slot))
871 (substitute-command-keys
872 (alist-get :documentation (cl--slot-descriptor-props slot)))
876 (defun cl--print-table (header rows)
877 ;; FIXME: Isn't this functionality already implemented elsewhere?
878 (let ((cols (apply #'vector (mapcar #'string-width header)))
881 (dotimes (i (length cols))
883 (curwidth (aref cols i))
884 (newwidth (if x (string-width x) 0)))
885 (if (> newwidth curwidth)
886 (setf (aref cols i) newwidth)))))
889 (dotimes (i (length cols))
890 (push (concat (propertize " "
892 `(space :align-to ,(+ col col-space)))
895 (cl-incf col (+ col-space (aref cols i))))
896 (let ((format (mapconcat #'identity (nreverse formats) "")))
897 (insert (apply #'format format
898 (mapcar (lambda (str) (propertize str 'face 'italic))
901 (insert (apply #'format format
902 (mapcar (lambda (str) (make-string (string-width str) ?—))
906 (insert (apply #'format format row) "\n"))))))
908 (defun cl--describe-class-slots (class)
909 "Print help description for the slots in CLASS.
910 Outputs to the current buffer."
911 (let* ((slots (cl--class-slots class))
912 (metatype (type-of class))
914 (cslots (condition-case nil
915 (cl-struct-slot-value metatype 'class-slots class)
916 (cl-struct-unknown-slot nil))))
917 (insert (propertize "Instance Allocated Slots:\n\n"
923 (list (cl-prin1-to-string (cl--slot-descriptor-name slot))
924 (cl-prin1-to-string (cl--slot-descriptor-type slot))
925 (cl-prin1-to-string (cl--slot-descriptor-initform slot))
926 (let ((doc (alist-get :documentation
927 (cl--slot-descriptor-props slot))))
930 (substitute-command-keys doc)))))
932 (cl--print-table `("Name" "Type" "Default" . ,(if has-doc '("Doc")))
935 (when (> (length cslots) 0)
936 (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
937 (mapc #'cl--describe-class-slot cslots))))
940 (run-hooks 'cl-extra-load-hook)
943 ;; byte-compile-dynamic: t
944 ;; generated-autoload-file: "cl-loaddefs.el"
948 ;;; cl-extra.el ends here