cl-extra.el 32.6 KB
Newer Older
1
;;; cl-extra.el --- Common Lisp features, part 2  -*- lexical-binding: t -*-
Richard M. Stallman's avatar
Richard M. Stallman committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1993, 2000-2019 Free Software Foundation, Inc.
Richard M. Stallman's avatar
Richard M. Stallman committed
4 5 6

;; Author: Dave Gillespie <daveg@synaptics.com>
;; Keywords: extensions
7
;; Package: emacs
Richard M. Stallman's avatar
Richard M. Stallman committed
8 9 10

;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Richard M. Stallman's avatar
Richard M. Stallman committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Richard M. Stallman's avatar
Richard M. Stallman committed
15 16 17 18 19 20 21

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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/>.
Richard M. Stallman's avatar
Richard M. Stallman committed
23

Richard M. Stallman's avatar
Richard M. Stallman committed
24
;;; Commentary:
Richard M. Stallman's avatar
Richard M. Stallman committed
25 26 27 28 29 30 31 32 33 34 35 36 37

;; These are extensions to Emacs Lisp that provide a degree of
;; Common Lisp compatibility, beyond what is already built-in
;; in Emacs Lisp.
;;
;; This package was written by Dave Gillespie; it is a complete
;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
;;
;; Bug reports, comments, and suggestions are welcome!

;; This file contains portions of the Common Lisp extensions
;; package which are autoloaded since they are relatively obscure.

Richard M. Stallman's avatar
Richard M. Stallman committed
38
;;; Code:
Richard M. Stallman's avatar
Richard M. Stallman committed
39

40
(require 'cl-lib)
Richard M. Stallman's avatar
Richard M. Stallman committed
41 42 43

;;; Type coercion.

44
;;;###autoload
45
(defun cl-coerce (x type)
Richard M. Stallman's avatar
Richard M. Stallman committed
46
  "Coerce OBJECT to type TYPE.
47 48
TYPE is a Common Lisp type specifier.
\n(fn OBJECT TYPE)"
Richard M. Stallman's avatar
Richard M. Stallman committed
49 50
  (cond ((eq type 'list) (if (listp x) x (append x nil)))
	((eq type 'vector) (if (vectorp x) x (vconcat x)))
51 52
	((eq type 'bool-vector)
         (if (bool-vector-p x) x (apply #'bool-vector (cl-coerce x 'list))))
Richard M. Stallman's avatar
Richard M. Stallman committed
53 54 55
	((eq type 'string) (if (stringp x) x (concat x)))
	((eq type 'array) (if (arrayp x) x (vconcat x)))
	((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
56 57
	((and (eq type 'character) (symbolp x))
         (cl-coerce (symbol-name x) type))
Richard M. Stallman's avatar
Richard M. Stallman committed
58
	((eq type 'float) (float x))
59
	((cl-typep x type) x)
Richard M. Stallman's avatar
Richard M. Stallman committed
60 61 62 63 64
	(t (error "Can't coerce %s to type %s" x type))))


;;; Predicates.

65
;;;###autoload
66
(defun cl-equalp (x y)
Juanma Barranquero's avatar
Juanma Barranquero committed
67
  "Return t if two Lisp objects have similar structures and contents.
Richard M. Stallman's avatar
Richard M. Stallman committed
68 69 70 71 72 73
This is like `equal', except that it accepts numerically equal
numbers of different types (float vs. integer), and also compares
strings case-insensitively."
  (cond ((eq x y) t)
	((stringp x)
	 (and (stringp y) (= (length x) (length y))
74
	      (or (string-equal x y)
75
		  (string-equal (downcase x) (downcase y))))) ;Lazy but simple!
Richard M. Stallman's avatar
Richard M. Stallman committed
76 77 78
	((numberp x)
	 (and (numberp y) (= x y)))
	((consp x)
79
	 (while (and (consp x) (consp y) (cl-equalp (car x) (car y)))
80
	   (setq x (cdr x) y (cdr y)))
81
	 (and (not (consp x)) (cl-equalp x y)))
Richard M. Stallman's avatar
Richard M. Stallman committed
82 83 84 85
	((vectorp x)
	 (and (vectorp y) (= (length x) (length y))
	      (let ((i (length x)))
		(while (and (>= (setq i (1- i)) 0)
86
			    (cl-equalp (aref x i) (aref y i))))
Richard M. Stallman's avatar
Richard M. Stallman committed
87 88 89 90 91 92
		(< i 0))))
	(t (equal x y))))


;;; Control structures.

93
;;;###autoload
94
(defun cl--mapcar-many (cl-func cl-seqs &optional acc)
Richard M. Stallman's avatar
Richard M. Stallman committed
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
  (if (cdr (cdr cl-seqs))
      (let* ((cl-res nil)
	     (cl-n (apply 'min (mapcar 'length cl-seqs)))
	     (cl-i 0)
	     (cl-args (copy-sequence cl-seqs))
	     cl-p1 cl-p2)
	(setq cl-seqs (copy-sequence cl-seqs))
	(while (< cl-i cl-n)
	  (setq cl-p1 cl-seqs cl-p2 cl-args)
	  (while cl-p1
	    (setcar cl-p2
		    (if (consp (car cl-p1))
			(prog1 (car (car cl-p1))
			  (setcar cl-p1 (cdr (car cl-p1))))
		      (aref (car cl-p1) cl-i)))
	    (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
111 112 113
	  (if acc
	      (push (apply cl-func cl-args) cl-res)
	    (apply cl-func cl-args))
Richard M. Stallman's avatar
Richard M. Stallman committed
114
	  (setq cl-i (1+ cl-i)))
115
	(and acc (nreverse cl-res)))
Richard M. Stallman's avatar
Richard M. Stallman committed
116 117 118 119 120 121
    (let ((cl-res nil)
	  (cl-x (car cl-seqs))
	  (cl-y (nth 1 cl-seqs)))
      (let ((cl-n (min (length cl-x) (length cl-y)))
	    (cl-i -1))
	(while (< (setq cl-i (1+ cl-i)) cl-n)
122 123 124 125 126 127
	  (let ((val (funcall cl-func
			      (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
			      (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))))
	    (when acc
	      (push val cl-res)))))
	(and acc (nreverse cl-res)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
128

129
;;;###autoload
130
(defun cl-map (cl-type cl-func cl-seq &rest cl-rest)
131 132 133
  "Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
TYPE is the sequence type to return.
\n(fn TYPE FUNCTION SEQUENCE...)"
134 135
  (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest)))
    (and cl-type (cl-coerce cl-res cl-type))))
Richard M. Stallman's avatar
Richard M. Stallman committed
136

137
;;;###autoload
138
(defun cl-maplist (cl-func cl-list &rest cl-rest)
139
  "Map FUNCTION to each sublist of LIST or LISTs.
Glenn Morris's avatar
Glenn Morris committed
140
Like `cl-mapcar', except applies to lists and their cdr's rather than to
141 142
the elements themselves.
\n(fn FUNCTION LIST...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
143 144 145 146 147
  (if cl-rest
      (let ((cl-res nil)
	    (cl-args (cons cl-list (copy-sequence cl-rest)))
	    cl-p)
	(while (not (memq nil cl-args))
148
	  (push (apply cl-func cl-args) cl-res)
Richard M. Stallman's avatar
Richard M. Stallman committed
149
	  (setq cl-p cl-args)
150
	  (while cl-p (setcar cl-p (cdr (pop cl-p)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
151 152 153
	(nreverse cl-res))
    (let ((cl-res nil))
      (while cl-list
154
	(push (funcall cl-func cl-list) cl-res)
Richard M. Stallman's avatar
Richard M. Stallman committed
155 156 157
	(setq cl-list (cdr cl-list)))
      (nreverse cl-res))))

Glenn Morris's avatar
Glenn Morris committed
158
;;;###autoload
Dave Love's avatar
Dave Love committed
159
(defun cl-mapc (cl-func cl-seq &rest cl-rest)
Glenn Morris's avatar
Glenn Morris committed
160
  "Like `cl-mapcar', but does not accumulate values returned by the function.
161
\n(fn FUNCTION SEQUENCE...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
162
  (if cl-rest
163 164 165 166 167 168 169 170
      (if (or (cdr cl-rest) (nlistp cl-seq) (nlistp (car cl-rest)))
          (progn
            (cl--mapcar-many cl-func (cons cl-seq cl-rest))
            cl-seq)
        (let ((cl-x cl-seq) (cl-y (car cl-rest)))
          (while (and cl-x cl-y)
            (funcall cl-func (pop cl-x) (pop cl-y)))
          cl-seq))
171
    (mapc cl-func cl-seq)))
Richard M. Stallman's avatar
Richard M. Stallman committed
172

173
;;;###autoload
174 175
(defun cl-mapl (cl-func cl-list &rest cl-rest)
  "Like `cl-maplist', but does not accumulate values returned by the function.
176
\n(fn FUNCTION LIST...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
177
  (if cl-rest
178 179 180 181 182 183
      (let ((cl-args (cons cl-list (copy-sequence cl-rest)))
	    cl-p)
	(while (not (memq nil cl-args))
          (apply cl-func cl-args)
	  (setq cl-p cl-args)
	  (while cl-p (setcar cl-p (cdr (pop cl-p))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
184 185 186 187
    (let ((cl-p cl-list))
      (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
  cl-list)

188
;;;###autoload
189
(defun cl-mapcan (cl-func cl-seq &rest cl-rest)
Glenn Morris's avatar
Glenn Morris committed
190
  "Like `cl-mapcar', but nconc's together the values returned by the function.
191
\n(fn FUNCTION SEQUENCE...)"
Mario Lang's avatar
Mario Lang committed
192 193 194
  (if cl-rest
      (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))
    (mapcan cl-func cl-seq)))
Richard M. Stallman's avatar
Richard M. Stallman committed
195

196
;;;###autoload
197 198
(defun cl-mapcon (cl-func cl-list &rest cl-rest)
  "Like `cl-maplist', but nconc's together the values returned by the function.
199
\n(fn FUNCTION LIST...)"
200
  (apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest)))
Richard M. Stallman's avatar
Richard M. Stallman committed
201

202
;;;###autoload
203
(defun cl-some (cl-pred cl-seq &rest cl-rest)
Richard M. Stallman's avatar
Richard M. Stallman committed
204
  "Return true if PREDICATE is true of any element of SEQ or SEQs.
205 206
If so, return the true (non-nil) value returned by PREDICATE.
\n(fn PREDICATE SEQ...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
207 208
  (if (or cl-rest (nlistp cl-seq))
      (catch 'cl-some
209
	(apply 'cl-map nil
Richard M. Stallman's avatar
Richard M. Stallman committed
210 211 212 213 214
	       (function (lambda (&rest cl-x)
			   (let ((cl-res (apply cl-pred cl-x)))
			     (if cl-res (throw 'cl-some cl-res)))))
	       cl-seq cl-rest) nil)
    (let ((cl-x nil))
215
      (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
216 217
      cl-x)))

218
;;;###autoload
219
(defun cl-every (cl-pred cl-seq &rest cl-rest)
220 221
  "Return true if PREDICATE is true of every element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
Richard M. Stallman's avatar
Richard M. Stallman committed
222 223
  (if (or cl-rest (nlistp cl-seq))
      (catch 'cl-every
224
	(apply 'cl-map nil
Richard M. Stallman's avatar
Richard M. Stallman committed
225 226 227 228 229 230 231
	       (function (lambda (&rest cl-x)
			   (or (apply cl-pred cl-x) (throw 'cl-every nil))))
	       cl-seq cl-rest) t)
    (while (and cl-seq (funcall cl-pred (car cl-seq)))
      (setq cl-seq (cdr cl-seq)))
    (null cl-seq)))

232
;;;###autoload
233
(defun cl-notany (cl-pred cl-seq &rest cl-rest)
234 235
  "Return true if PREDICATE is false of every element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
236
  (not (apply 'cl-some cl-pred cl-seq cl-rest)))
Richard M. Stallman's avatar
Richard M. Stallman committed
237

238
;;;###autoload
239
(defun cl-notevery (cl-pred cl-seq &rest cl-rest)
240 241
  "Return true if PREDICATE is false of some element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
242
  (not (apply 'cl-every cl-pred cl-seq cl-rest)))
Richard M. Stallman's avatar
Richard M. Stallman committed
243

244
;;;###autoload
245
(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
Richard M. Stallman's avatar
Richard M. Stallman committed
246
  (or cl-base
Dave Love's avatar
Dave Love committed
247
      (setq cl-base (copy-sequence [0])))
248
  (map-keymap
Richard M. Stallman's avatar
Richard M. Stallman committed
249 250 251 252
   (function
    (lambda (cl-key cl-bind)
      (aset cl-base (1- (length cl-base)) cl-key)
      (if (keymapp cl-bind)
253
	  (cl--map-keymap-recursively
Richard M. Stallman's avatar
Richard M. Stallman committed
254
	   cl-func-rec cl-bind
Dave Love's avatar
Dave Love committed
255
	   (vconcat cl-base (list 0)))
Richard M. Stallman's avatar
Richard M. Stallman committed
256 257 258
	(funcall cl-func-rec cl-base cl-bind))))
   cl-map))

259
;;;###autoload
260
(defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
Richard M. Stallman's avatar
Richard M. Stallman committed
261 262 263
  (or cl-what (setq cl-what (current-buffer)))
  (if (bufferp cl-what)
      (let (cl-mark cl-mark2 (cl-next t) cl-next2)
Dave Love's avatar
Dave Love committed
264
	(with-current-buffer cl-what
Richard M. Stallman's avatar
Richard M. Stallman committed
265 266 267
	  (setq cl-mark (copy-marker (or cl-start (point-min))))
	  (setq cl-mark2 (and cl-end (copy-marker cl-end))))
	(while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
Dave Love's avatar
Dave Love committed
268 269 270 271 272
	  (setq cl-next (if cl-prop (next-single-property-change
				     cl-mark cl-prop cl-what)
			  (next-property-change cl-mark cl-what))
		cl-next2 (or cl-next (with-current-buffer cl-what
				       (point-max))))
Richard M. Stallman's avatar
Richard M. Stallman committed
273 274 275 276 277 278 279
	  (funcall cl-func (prog1 (marker-position cl-mark)
			     (set-marker cl-mark cl-next2))
		   (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
	(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
    (or cl-start (setq cl-start 0))
    (or cl-end (setq cl-end (length cl-what)))
    (while (< cl-start cl-end)
Dave Love's avatar
Dave Love committed
280 281 282
      (let ((cl-next (or (if cl-prop (next-single-property-change
				      cl-start cl-prop cl-what)
			   (next-property-change cl-start cl-what))
Richard M. Stallman's avatar
Richard M. Stallman committed
283 284 285 286
			 cl-end)))
	(funcall cl-func cl-start (min cl-next cl-end))
	(setq cl-start cl-next)))))

287
;;;###autoload
288
(defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
Richard M. Stallman's avatar
Richard M. Stallman committed
289
  (or cl-buffer (setq cl-buffer (current-buffer)))
290 291 292 293 294 295 296 297 298 299 300 301 302 303
  (let (cl-ovl)
    (with-current-buffer cl-buffer
      (setq cl-ovl (overlay-lists))
      (if cl-start (setq cl-start (copy-marker cl-start)))
      (if cl-end (setq cl-end (copy-marker cl-end))))
    (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
    (while (and cl-ovl
		(or (not (overlay-start (car cl-ovl)))
		    (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
		    (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
		    (not (funcall cl-func (car cl-ovl) cl-arg))))
      (setq cl-ovl (cdr cl-ovl)))
    (if cl-start (set-marker cl-start nil))
    (if cl-end (set-marker cl-end nil))))
Richard M. Stallman's avatar
Richard M. Stallman committed
304

305
;;; Support for `setf'.
306
;;;###autoload
307
(defun cl--set-frame-visible-p (frame val)
Richard M. Stallman's avatar
Richard M. Stallman committed
308 309 310 311 312 313 314 315
  (cond ((null val) (make-frame-invisible frame))
	((eq val 'icon) (iconify-frame frame))
	(t (make-frame-visible frame)))
  val)


;;; Numbers.

316
;;;###autoload
317
(defun cl-gcd (&rest args)
Richard M. Stallman's avatar
Richard M. Stallman committed
318
  "Return the greatest common divisor of the arguments."
319 320 321 322 323
  (let ((a (or (pop args) 0)))
    (dolist (b args)
      (while (/= b 0)
        (setq b (% a (setq a b)))))
    (abs a)))
Richard M. Stallman's avatar
Richard M. Stallman committed
324

325
;;;###autoload
326
(defun cl-lcm (&rest args)
Richard M. Stallman's avatar
Richard M. Stallman committed
327 328 329
  "Return the least common multiple of the arguments."
  (if (memq 0 args)
      0
330 331 332 333
    (let ((a (or (pop args) 1)))
      (dolist (b args)
        (setq a (* (/ a (cl-gcd a b)) b)))
      (abs a))))
Richard M. Stallman's avatar
Richard M. Stallman committed
334

335
;;;###autoload
336
(defun cl-isqrt (x)
337
  "Return the integer square root of the (integer) argument."
338
  (if (and (integerp x) (> x 0))
339
      (let ((g (ash 2 (/ (logb x) 2)))
Richard M. Stallman's avatar
Richard M. Stallman committed
340
	    g2)
341
	(while (< (setq g2 (/ (+ g (/ x g)) 2)) g)
Richard M. Stallman's avatar
Richard M. Stallman committed
342 343
	  (setq g g2))
	g)
344
    (if (eq x 0) 0 (signal 'arith-error nil))))
Richard M. Stallman's avatar
Richard M. Stallman committed
345

346
;;;###autoload
347
(defun cl-floor (x &optional y)
Richard M. Stallman's avatar
Richard M. Stallman committed
348 349
  "Return a list of the floor of X and the fractional part of X.
With two arguments, return floor and remainder of their quotient."
350 351
  (let ((q (floor x y)))
    (list q (- x (if y (* y q) q)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
352

353
;;;###autoload
354
(defun cl-ceiling (x &optional y)
Richard M. Stallman's avatar
Richard M. Stallman committed
355 356
  "Return a list of the ceiling of X and the fractional part of X.
With two arguments, return ceiling and remainder of their quotient."
357
  (let ((res (cl-floor x y)))
Richard M. Stallman's avatar
Richard M. Stallman committed
358 359 360
    (if (= (car (cdr res)) 0) res
      (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))

361
;;;###autoload
362
(defun cl-truncate (x &optional y)
Richard M. Stallman's avatar
Richard M. Stallman committed
363 364 365
  "Return a list of the integer part of X and the fractional part of X.
With two arguments, return truncation and remainder of their quotient."
  (if (eq (>= x 0) (or (null y) (>= y 0)))
366
      (cl-floor x y) (cl-ceiling x y)))
Richard M. Stallman's avatar
Richard M. Stallman committed
367

368
;;;###autoload
369
(defun cl-round (x &optional y)
Richard M. Stallman's avatar
Richard M. Stallman committed
370 371 372 373 374
  "Return a list of X rounded to the nearest integer and the remainder.
With two arguments, return rounding and remainder of their quotient."
  (if y
      (if (and (integerp x) (integerp y))
	  (let* ((hy (/ y 2))
375
		 (res (cl-floor (+ x hy) y)))
Richard M. Stallman's avatar
Richard M. Stallman committed
376 377 378 379 380 381 382 383 384 385 386
	    (if (and (= (car (cdr res)) 0)
		     (= (+ hy hy) y)
		     (/= (% (car res) 2) 0))
		(list (1- (car res)) hy)
	      (list (car res) (- (car (cdr res)) hy))))
	(let ((q (round (/ x y))))
	  (list q (- x (* q y)))))
    (if (integerp x) (list x 0)
      (let ((q (round x)))
	(list q (- x q))))))

387
;;;###autoload
388
(defun cl-mod (x y)
Richard M. Stallman's avatar
Richard M. Stallman committed
389
  "The remainder of X divided by Y, with the same sign as Y."
390
  (nth 1 (cl-floor x y)))
Richard M. Stallman's avatar
Richard M. Stallman committed
391

392
;;;###autoload
393
(defun cl-rem (x y)
Richard M. Stallman's avatar
Richard M. Stallman committed
394
  "The remainder of X divided by Y, with the same sign as X."
395
  (nth 1 (cl-truncate x y)))
Richard M. Stallman's avatar
Richard M. Stallman committed
396

397
;;;###autoload
398
(defun cl-signum (x)
399 400
  "Return 1 if X is positive, -1 if negative, 0 if zero."
  (cond ((> x 0) 1) ((< x 0) -1) (t 0)))
Richard M. Stallman's avatar
Richard M. Stallman committed
401

402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
;;;###autoload
(cl-defun cl-parse-integer (string &key start end radix junk-allowed)
  "Parse integer from the substring of STRING from START to END.
STRING may be surrounded by whitespace chars (chars with syntax ` ').
Other non-digit chars are considered junk.
RADIX is an integer between 2 and 36, the default is 10.  Signal
an error if the substring between START and END cannot be parsed
as an integer unless JUNK-ALLOWED is non-nil."
  (cl-check-type string string)
  (let* ((start (or start 0))
	 (len	(length string))
	 (end   (or end len))
	 (radix (or radix 10)))
    (or (<= start end len)
	(error "Bad interval: [%d, %d)" start end))
    (cl-flet ((skip-whitespace ()
		(while (and (< start end)
			    (= 32 (char-syntax (aref string start))))
		  (setq start (1+ start)))))
      (skip-whitespace)
      (let ((sign (cl-case (and (< start end) (aref string start))
		    (?+ (cl-incf start) +1)
		    (?- (cl-incf start) -1)
		    (t  +1)))
	    digit sum)
	(while (and (< start end)
		    (setq digit (cl-digit-char-p (aref string start) radix)))
	  (setq sum (+ (* (or sum 0) radix) digit)
		start (1+ start)))
	(skip-whitespace)
	(cond ((and junk-allowed (null sum)) sum)
	      (junk-allowed (* sign sum))
434
	      ((or (/= start end) (null sum))
435
	       (error "Not an integer string: `%s'" string))
436 437
	      (t (* sign sum)))))))

Richard M. Stallman's avatar
Richard M. Stallman committed
438 439 440

;; Random numbers.

441
(defun cl--random-time ()
Paul Eggert's avatar
Paul Eggert committed
442
  (car (time-convert nil t)))
443 444 445 446 447 448 449 450 451 452 453

;;;###autoload (autoload 'cl-random-state-p "cl-extra")
(cl-defstruct (cl--random-state
               (:copier nil)
               (:predicate cl-random-state-p)
               (:constructor nil)
               (:constructor cl--make-random-state (vec)))
  (i -1) (j 30) vec)

(defvar cl--random-state (cl--make-random-state (cl--random-time)))

454
;;;###autoload
455
(defun cl-random (lim &optional state)
Richard M. Stallman's avatar
Richard M. Stallman committed
456 457
  "Return a random nonnegative number less than LIM, an integer or float.
Optional second arg STATE is a random-state object."
458
  (or state (setq state cl--random-state))
Richard M. Stallman's avatar
Richard M. Stallman committed
459
  ;; Inspired by "ran3" from Numerical Recipes.  Additive congruential method.
460
  (let ((vec (cl--random-state-vec state)))
Richard M. Stallman's avatar
Richard M. Stallman committed
461
    (if (integerp vec)
462
	(let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1))
463 464
	  (setf (cl--random-state-vec state)
                (setq vec (make-vector 55 nil)))
Richard M. Stallman's avatar
Richard M. Stallman committed
465 466 467
	  (aset vec 0 j)
	  (while (> (setq i (% (+ i 21) 55)) 0)
	    (aset vec i (setq j (prog1 k (setq k (- j k))))))
468
	  (while (< (setq i (1+ i)) 200) (cl-random 2 state))))
469 470
    (let* ((i (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-i state)))
	   (j (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-j state)))
Richard M. Stallman's avatar
Richard M. Stallman committed
471 472 473
	   (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
      (if (integerp lim)
	  (if (<= lim 512) (% n lim)
474
	    (if (> lim 8388607) (setq n (+ (ash n 9) (cl-random 512 state))))
Richard M. Stallman's avatar
Richard M. Stallman committed
475 476
	    (let ((mask 1023))
	      (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
477
	      (if (< (setq n (logand n mask)) lim) n (cl-random lim state))))
Richard M. Stallman's avatar
Richard M. Stallman committed
478 479
	(* (/ n '8388608e0) lim)))))

480
;;;###autoload
481
(defun cl-make-random-state (&optional state)
482
  "Return a copy of random-state STATE, or of the internal state if omitted.
Richard M. Stallman's avatar
Richard M. Stallman committed
483
If STATE is t, return a new state object seeded from the time of day."
484 485
  (unless state (setq state cl--random-state))
  (if (cl-random-state-p state)
486
      (copy-sequence state)
487
    (cl--make-random-state (if (integerp state) state (cl--random-time)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
488 489 490

;; Implementation limits.

491 492
(defun cl--finite-do (func a b)
  (condition-case _
Richard M. Stallman's avatar
Richard M. Stallman committed
493 494 495 496
      (let ((res (funcall func a b)))   ; check for IEEE infinity
	(and (numberp res) (/= res (/ res 2)) res))
    (arith-error nil)))

497
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
498
(defun cl-float-limits ()
499
  "Initialize the Common Lisp floating-point parameters.
500 501 502 503 504
This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
`cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon',
`cl-float-negative-epsilon', `cl-least-positive-normalized-float', and
`cl-least-negative-normalized-float'."
  (or cl-most-positive-float (not (numberp '2e1))
Richard M. Stallman's avatar
Richard M. Stallman committed
505 506
      (let ((x '2e0) y z)
	;; Find maximum exponent (first two loops are optimizations)
507 508 509
	(while (cl--finite-do '* x x) (setq x (* x x)))
	(while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
	(while (cl--finite-do '+ x x) (setq x (+ x x)))
Richard M. Stallman's avatar
Richard M. Stallman committed
510
	(setq z x y (/ x 2))
511
	;; Now cl-fill in 1's in the mantissa.
512
	(while (and (cl--finite-do '+ x y) (/= (+ x y) x))
Richard M. Stallman's avatar
Richard M. Stallman committed
513
	  (setq x (+ x y) y (/ y 2)))
514 515
	(setq cl-most-positive-float x
	      cl-most-negative-float (- x))
Richard M. Stallman's avatar
Richard M. Stallman committed
516 517
	;; Divide down until mantissa starts rounding.
	(setq x (/ x z) y (/ 16 z) x (* x y))
518
	(while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
Richard M. Stallman's avatar
Richard M. Stallman committed
519 520
		 (arith-error nil))
	  (setq x (/ x 2) y (/ y 2)))
521 522
	(setq cl-least-positive-normalized-float y
	      cl-least-negative-normalized-float (- y))
Richard M. Stallman's avatar
Richard M. Stallman committed
523
	;; Divide down until value underflows to zero.
524
	(setq x (/ z) y x)
525
	(while (condition-case _ (> (/ x 2) 0) (arith-error nil))
Richard M. Stallman's avatar
Richard M. Stallman committed
526
	  (setq x (/ x 2)))
527 528
	(setq cl-least-positive-float x
	      cl-least-negative-float (- x))
Richard M. Stallman's avatar
Richard M. Stallman committed
529 530
	(setq x '1e0)
	(while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
531
	(setq cl-float-epsilon (* x 2))
Richard M. Stallman's avatar
Richard M. Stallman committed
532 533
	(setq x '1e0)
	(while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
534
	(setq cl-float-negative-epsilon (* x 2))))
Richard M. Stallman's avatar
Richard M. Stallman committed
535 536 537 538 539
  nil)


;;; Sequence functions.

540
;;;###autoload
541
(defun cl-subseq (seq start &optional end)
Richard M. Stallman's avatar
Richard M. Stallman committed
542 543
  "Return the subsequence of SEQ from START to END.
If END is omitted, it defaults to the length of the sequence.
544 545
If START or END is negative, it counts from the end.
Signal an error if START or END are outside of the sequence (i.e
546
too large if positive or too small if negative)."
Stefan Monnier's avatar
Stefan Monnier committed
547 548
  (declare (gv-setter
            (lambda (new)
549 550 551
              (macroexp-let2 nil new new
		`(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
			,new)))))
552 553 554 555
  (cond ((or (stringp seq) (vectorp seq)) (substring seq start end))
        ((listp seq)
         (let (len
               (errtext (format "Bad bounding indices: %s, %s" start end)))
556 557
           (and end (< end 0) (setq end (+ end (setq len (length seq)))))
           (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
558 559 560 561 562 563 564 565 566 567 568 569
           (unless (>= start 0)
             (error "%s" errtext))
           (when (> start 0)
             (setq seq (nthcdr (1- start) seq))
             (or seq (error "%s" errtext))
             (setq seq (cdr seq)))
           (if end
               (let ((res nil))
                 (while (and (>= (setq end (1- end)) start) seq)
                   (push (pop seq) res))
                 (or (= (1+ end) start) (error "%s" errtext))
                 (nreverse res))
570
             (copy-sequence seq))))
571
        (t (error "Unsupported sequence: %s" seq))))
Richard M. Stallman's avatar
Richard M. Stallman committed
572

573
;;;###autoload
574
(defun cl-concatenate (type &rest sequences)
575
  "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
576 577
\n(fn TYPE SEQUENCE...)"
  (pcase type
578 579 580
    ('vector (apply #'vconcat sequences))
    ('string (apply #'concat sequences))
    ('list (apply #'append (append sequences '(nil))))
581
    (_ (error "Not a sequence type name: %S" type))))
Richard M. Stallman's avatar
Richard M. Stallman committed
582 583 584

;;; List functions.

585
;;;###autoload
586
(defun cl-revappend (x y)
Richard M. Stallman's avatar
Richard M. Stallman committed
587 588 589
  "Equivalent to (append (reverse X) Y)."
  (nconc (reverse x) y))

590
;;;###autoload
591
(defun cl-nreconc (x y)
Richard M. Stallman's avatar
Richard M. Stallman committed
592 593 594
  "Equivalent to (nconc (nreverse X) Y)."
  (nconc (nreverse x) y))

595
;;;###autoload
596
(defun cl-list-length (x)
597
  "Return the length of list X.  Return nil if list is circular."
Paul Eggert's avatar
Paul Eggert committed
598 599 600 601
  (cl-check-type x list)
  (condition-case nil
      (length x)
    (circular-list)))
Richard M. Stallman's avatar
Richard M. Stallman committed
602

603
;;;###autoload
604
(defun cl-tailp (sublist list)
Richard M. Stallman's avatar
Richard M. Stallman committed
605 606 607 608 609 610 611
  "Return true if SUBLIST is a tail of LIST."
  (while (and (consp list) (not (eq sublist list)))
    (setq list (cdr list)))
  (if (numberp sublist) (equal sublist list) (eq sublist list)))

;;; Property lists.

612
;;;###autoload
613
(defun cl-get (sym tag &optional def)
614 615
  "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
\n(fn SYMBOL PROPNAME &optional DEFAULT)"
Stefan Monnier's avatar
Stefan Monnier committed
616
  (declare (compiler-macro cl--compiler-macro-get)
617
           (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store))))
618
  (cl-getf (symbol-plist sym) tag def))
619
(autoload 'cl--compiler-macro-get "cl-macs")
Richard M. Stallman's avatar
Richard M. Stallman committed
620

621
;;;###autoload
622
(defun cl-getf (plist tag &optional def)
Richard M. Stallman's avatar
Richard M. Stallman committed
623
  "Search PROPLIST for property PROPNAME; return its value or DEFAULT.
624 625
PROPLIST is a list of the sort returned by `symbol-plist'.
\n(fn PROPLIST PROPNAME &optional DEFAULT)"
Stefan Monnier's avatar
Stefan Monnier committed
626 627 628
  (declare (gv-expander
            (lambda (do)
              (gv-letplace (getter setter) plist
Leo Liu's avatar
Leo Liu committed
629 630 631 632 633 634 635 636
                (macroexp-let2* nil ((k tag) (d def))
                  (funcall do `(cl-getf ,getter ,k ,d)
			   (lambda (v)
			     (macroexp-let2 nil val v
			       `(progn
				  ,(funcall setter
					    `(cl--set-getf ,getter ,k ,val))
				  ,val)))))))))
637 638
  (let ((val-tail (cdr-safe (plist-member plist tag))))
    (if val-tail (car val-tail) def)))
Richard M. Stallman's avatar
Richard M. Stallman committed
639

640
;;;###autoload
641
(defun cl--set-getf (plist tag val)
642 643 644
  (let ((val-tail (cdr-safe (plist-member plist tag))))
    (if val-tail (progn (setcar val-tail val) plist)
      (cl-list* tag val plist))))
Richard M. Stallman's avatar
Richard M. Stallman committed
645

646
;;;###autoload
647
(defun cl--do-remf (plist tag)
Richard M. Stallman's avatar
Richard M. Stallman committed
648
  (let ((p (cdr plist)))
649 650
    ;; Can't use `plist-member' here because it goes to the cons-cell
    ;; of TAG and we need the one before.
Richard M. Stallman's avatar
Richard M. Stallman committed
651 652 653
    (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
    (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))

654
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
655
(defun cl-remprop (sym tag)
656 657
  "Remove from SYMBOL's plist the property PROPNAME and its value.
\n(fn SYMBOL PROPNAME)"
Richard M. Stallman's avatar
Richard M. Stallman committed
658 659 660
  (let ((plist (symbol-plist sym)))
    (if (and plist (eq tag (car plist)))
	(progn (setplist sym (cdr (cdr plist))) t)
661
      (cl--do-remf plist tag))))
Richard M. Stallman's avatar
Richard M. Stallman committed
662

663 664 665 666 667 668 669
;;; Streams.

;;;###autoload
(defun cl-fresh-line (&optional stream)
  "Output a newline unless already at the beginning of a line."
  (terpri stream 'ensure))

Richard M. Stallman's avatar
Richard M. Stallman committed
670 671 672 673 674 675 676 677 678
;;; Some debugging aids.

(defun cl-prettyprint (form)
  "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
  (let ((pt (point)) last)
    (insert "\n" (prin1-to-string form) "\n")
    (setq last (point))
    (goto-char (1+ pt))
    (while (search-forward "(quote " last t)
679
      (delete-char -7)
Richard M. Stallman's avatar
Richard M. Stallman committed
680 681 682 683
      (insert "'")
      (forward-sexp)
      (delete-char 1))
    (goto-char (1+ pt))
684
    (cl--do-prettyprint)))
Richard M. Stallman's avatar
Richard M. Stallman committed
685

686
(defun cl--do-prettyprint ()
Richard M. Stallman's avatar
Richard M. Stallman committed
687 688 689 690 691
  (skip-chars-forward " ")
  (if (looking-at "(")
      (let ((skip (or (looking-at "((") (looking-at "(prog")
		      (looking-at "(unwind-protect ")
		      (looking-at "(function (")
692
		      (looking-at "(cl--block-wrapper ")))
Richard M. Stallman's avatar
Richard M. Stallman committed
693 694 695 696 697 698 699 700 701
	    (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
	    (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
	    (set (looking-at "(p?set[qf] ")))
	(if (or skip let
		(progn
		  (forward-sexp)
		  (and (>= (current-column) 78) (progn (backward-sexp) t))))
	    (let ((nl t))
	      (forward-char 1)
702 703 704
	      (cl--do-prettyprint)
	      (or skip (looking-at ")") (cl--do-prettyprint))
	      (or (not two) (looking-at ")") (cl--do-prettyprint))
Richard M. Stallman's avatar
Richard M. Stallman committed
705 706 707 708
	      (while (not (looking-at ")"))
		(if set (setq nl (not nl)))
		(if nl (insert "\n"))
		(lisp-indent-line)
709
		(cl--do-prettyprint))
Richard M. Stallman's avatar
Richard M. Stallman committed
710 711 712
	      (forward-char 1))))
    (forward-sexp)))

713
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
714
(defun cl-prettyexpand (form &optional full)
Glenn Morris's avatar
Glenn Morris committed
715 716 717
  "Expand macros in FORM and insert the pretty-printed result.
Optional argument FULL non-nil means to expand all macros,
including `cl-block' and `cl-eval-when'."
Richard M. Stallman's avatar
Richard M. Stallman committed
718
  (message "Expanding...")
719
  (let ((cl--compiling-file full)
Richard M. Stallman's avatar
Richard M. Stallman committed
720
	(byte-compile-macro-environment nil))
721 722
    (setq form (macroexpand-all form
                                (and (not full) '((cl-block) (cl-eval-when)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
723 724 725 726
    (message "Formatting...")
    (prog1 (cl-prettyprint form)
      (message ""))))

727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743
;;; Integration into the online help system.

(eval-when-compile (require 'cl-macs))  ;Explicitly, for cl--find-class.
(require 'help-mode)

;; FIXME: We could go crazy and add another entry so describe-symbol can be
;; used with the slot names of CL structs (and/or EIEIO objects).
(add-to-list 'describe-symbol-backends
             `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s))))

(defconst cl--typedef-regexp
  (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct"
                            "cl-deftype" "deftype"))
          "[ \t\r\n]+%s[ \t\r\n]+"))
(with-eval-after-load 'find-func
  (defvar find-function-regexp-alist)
  (add-to-list 'find-function-regexp-alist
744
               '(define-type . cl--typedef-regexp)))
745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785

(define-button-type 'cl-help-type
  :supertype 'help-function-def
  'help-function #'cl-describe-type
  'help-echo (purecopy "mouse-2, RET: describe this type"))

(define-button-type 'cl-type-definition
  :supertype 'help-function-def
  'help-echo (purecopy "mouse-2, RET: find type definition"))

(declare-function help-fns-short-filename "help-fns" (filename))

;;;###autoload
(defun cl-find-class (type) (cl--find-class type))

;;;###autoload
(defun cl-describe-type (type)
  "Display the documentation for type TYPE (a symbol)."
  (interactive
   (let ((str (completing-read "Describe type: " obarray #'cl-find-class t)))
     (if (<= (length str) 0)
         (user-error "Abort!")
       (list (intern str)))))
  (help-setup-xref (list #'cl-describe-type type)
                   (called-interactively-p 'interactive))
  (save-excursion
    (with-help-window (help-buffer)
      (with-current-buffer standard-output
        (let ((class (cl-find-class type)))
          (if class
              (cl--describe-class type class)
            ;; FIXME: Describe other types (the built-in ones, or those from
            ;; cl-deftype).
            (user-error "Unknown type %S" type))))
      (with-current-buffer standard-output
        ;; Return the text we displayed.
        (buffer-string)))))

(defun cl--describe-class (type &optional class)
  (unless class (setq class (cl--find-class type)))
  (let ((location (find-lisp-object-file-name type 'define-type))
786
        (metatype (type-of class)))
787
    (insert (symbol-name type)
788
            (substitute-command-keys " is a type (of kind `"))
789 790
    (help-insert-xref-button (symbol-name metatype)
                             'cl-help-type metatype)
791
    (insert (substitute-command-keys "')"))
792
    (when location
793
      (insert (substitute-command-keys " in `"))
794 795 796
      (help-insert-xref-button
       (help-fns-short-filename location)
       'cl-type-definition type location 'define-type)
797
      (insert (substitute-command-keys "'")))
798 799 800 801 802 803 804 805 806
    (insert ".\n")

    ;; Parents.
    (let ((pl (cl--class-parents class))
          cur)
      (when pl
        (insert " Inherits from ")
        (while (setq cur (pop pl))
          (setq cur (cl--class-name cur))
807
          (insert (substitute-command-keys "`"))
808 809
          (help-insert-xref-button (symbol-name cur)
                                   'cl-help-type cur)
810
          (insert (substitute-command-keys (if pl "', " "'"))))
811 812 813 814 815 816 817 818 819 820
        (insert ".\n")))

    ;; Children, if available.  ¡For EIEIO!
    (let ((ch (condition-case nil
                  (cl-struct-slot-value metatype 'children class)
                (cl-struct-unknown-slot nil)))
          cur)
      (when ch
        (insert " Children ")
        (while (setq cur (pop ch))
821
          (insert (substitute-command-keys "`"))
822 823
          (help-insert-xref-button (symbol-name cur)
                                   'cl-help-type cur)
824
          (insert (substitute-command-keys (if ch "', " "'"))))
825 826 827 828 829 830 831 832 833 834 835
        (insert ".\n")))

    ;; Type's documentation.
    (let ((doc (cl--class-docstring class)))
      (when doc
        (insert "\n" doc "\n\n")))

    ;; Describe all the slots in this class.
    (cl--describe-class-slots class)

    ;; Describe all the methods specific to this class.
836
    (let ((generics (cl-generic-all-functions type)))
837 838 839
      (when generics
        (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
        (dolist (generic generics)
840
          (insert (substitute-command-keys "`"))
841 842
          (help-insert-xref-button (symbol-name generic)
                                   'help-function generic)
843
          (insert (substitute-command-keys "'"))
Stefan Monnier's avatar