code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/cl-extra.el

   1 ;;; cl-extra.el --- Common Lisp features, part 2
   2
   3 ;; Copyright (C) 1993, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008, 2009, 2010, 2011  Free Software Foundation, Inc.
   5
   6 ;; Author: Dave Gillespie <daveg@synaptics.com>
   7 ;; Keywords: extensions
   8 ;; Package: emacs
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; These are extensions to Emacs Lisp that provide a degree of
  28 ;; Common Lisp compatibility, beyond what is already built-in
  29 ;; in Emacs Lisp.
  30 ;;
  31 ;; This package was written by Dave Gillespie; it is a complete
  32 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
  33 ;;
  34 ;; Bug reports, comments, and suggestions are welcome!
  35
  36 ;; This file contains portions of the Common Lisp extensions
  37 ;; package which are autoloaded since they are relatively obscure.
  38
  39 ;;; Code:
  40
  41 (require 'cl)
  42
  43 ;;; Type coercion.
  44
  45 ;;;###autoload
  46 (defun coerce (x type)
  47   "Coerce OBJECT to type TYPE.
  48 TYPE is a Common Lisp type specifier.
  49 \n(fn OBJECT TYPE)"
  50   (cond ((eq type 'list) (if (listp x) x (append x nil)))
  51         ((eq type 'vector) (if (vectorp x) x (vconcat x)))
  52         ((eq type 'string) (if (stringp x) x (concat x)))
  53         ((eq type 'array) (if (arrayp x) x (vconcat x)))
  54         ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
  55         ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
  56         ((eq type 'float) (float x))
  57         ((typep x type) x)
  58         (t (error "Can't coerce %s to type %s" x type))))
  59
  60
  61 ;;; Predicates.
  62
  63 ;;;###autoload
  64 (defun 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   (cond ((eq x y) t)
  70         ((stringp x)
  71          (and (stringp y) (= (length x) (length y))
  72               (or (string-equal x y)
  73                   (string-equal (downcase x) (downcase y)))))   ; lazy but simple!
  74         ((numberp x)
  75          (and (numberp y) (= x y)))
  76         ((consp x)
  77          (while (and (consp x) (consp y) (equalp (car x) (car y)))
  78            (setq x (cdr x) y (cdr y)))
  79          (and (not (consp x)) (equalp x y)))
  80         ((vectorp x)
  81          (and (vectorp y) (= (length x) (length y))
  82               (let ((i (length x)))
  83                 (while (and (>= (setq i (1- i)) 0)
  84                             (equalp (aref x i) (aref y i))))
  85                 (< i 0))))
  86         (t (equal x y))))
  87
  88
  89 ;;; Control structures.
  90
  91 ;;;###autoload
  92 (defun cl-mapcar-many (cl-func cl-seqs)
  93   (if (cdr (cdr cl-seqs))
  94       (let* ((cl-res nil)
  95              (cl-n (apply 'min (mapcar 'length cl-seqs)))
  96              (cl-i 0)
  97              (cl-args (copy-sequence cl-seqs))
  98              cl-p1 cl-p2)
  99         (setq cl-seqs (copy-sequence cl-seqs))
 100         (while (< cl-i cl-n)
 101           (setq cl-p1 cl-seqs cl-p2 cl-args)
 102           (while cl-p1
 103             (setcar cl-p2
 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)))
 109           (push (apply cl-func cl-args) cl-res)
 110           (setq cl-i (1+ cl-i)))
 111         (nreverse cl-res))
 112     (let ((cl-res nil)
 113           (cl-x (car cl-seqs))
 114           (cl-y (nth 1 cl-seqs)))
 115       (let ((cl-n (min (length cl-x) (length cl-y)))
 116             (cl-i -1))
 117         (while (< (setq cl-i (1+ cl-i)) cl-n)
 118           (push (funcall cl-func
 119                             (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
 120                             (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
 121                    cl-res)))
 122       (nreverse cl-res))))
 123
 124 ;;;###autoload
 125 (defun map (cl-type cl-func cl-seq &rest cl-rest)
 126   "Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
 127 TYPE is the sequence type to return.
 128 \n(fn TYPE FUNCTION SEQUENCE...)"
 129   (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
 130     (and cl-type (coerce cl-res cl-type))))
 131
 132 ;;;###autoload
 133 (defun maplist (cl-func cl-list &rest cl-rest)
 134   "Map FUNCTION to each sublist of LIST or LISTs.
 135 Like `mapcar', except applies to lists and their cdr's rather than to
 136 the elements themselves.
 137 \n(fn FUNCTION LIST...)"
 138   (if cl-rest
 139       (let ((cl-res nil)
 140             (cl-args (cons cl-list (copy-sequence cl-rest)))
 141             cl-p)
 142         (while (not (memq nil cl-args))
 143           (push (apply cl-func cl-args) cl-res)
 144           (setq cl-p cl-args)
 145           (while cl-p (setcar cl-p (cdr (pop cl-p)) )))
 146         (nreverse cl-res))
 147     (let ((cl-res nil))
 148       (while cl-list
 149         (push (funcall cl-func cl-list) cl-res)
 150         (setq cl-list (cdr cl-list)))
 151       (nreverse cl-res))))
 152
 153 (defun cl-mapc (cl-func cl-seq &rest cl-rest)
 154   "Like `mapcar', but does not accumulate values returned by the function.
 155 \n(fn FUNCTION SEQUENCE...)"
 156   (if cl-rest
 157       (progn (apply 'map nil cl-func cl-seq cl-rest)
 158              cl-seq)
 159     (mapc cl-func cl-seq)))
 160
 161 ;;;###autoload
 162 (defun mapl (cl-func cl-list &rest cl-rest)
 163   "Like `maplist', but does not accumulate values returned by the function.
 164 \n(fn FUNCTION LIST...)"
 165   (if cl-rest
 166       (apply 'maplist cl-func cl-list cl-rest)
 167     (let ((cl-p cl-list))
 168       (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
 169   cl-list)
 170
 171 ;;;###autoload
 172 (defun mapcan (cl-func cl-seq &rest cl-rest)
 173   "Like `mapcar', but nconc's together the values returned by the function.
 174 \n(fn FUNCTION SEQUENCE...)"
 175   (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
 176
 177 ;;;###autoload
 178 (defun mapcon (cl-func cl-list &rest cl-rest)
 179   "Like `maplist', but nconc's together the values returned by the function.
 180 \n(fn FUNCTION LIST...)"
 181   (apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
 182
 183 ;;;###autoload
 184 (defun some (cl-pred cl-seq &rest cl-rest)
 185   "Return true if PREDICATE is true of any element of SEQ or SEQs.
 186 If so, return the true (non-nil) value returned by PREDICATE.
 187 \n(fn PREDICATE SEQ...)"
 188   (if (or cl-rest (nlistp cl-seq))
 189       (catch 'cl-some
 190         (apply 'map nil
 191                (function (lambda (&rest cl-x)
 192                            (let ((cl-res (apply cl-pred cl-x)))
 193                              (if cl-res (throw 'cl-some cl-res)))))
 194                cl-seq cl-rest) nil)
 195     (let ((cl-x nil))
 196       (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
 197       cl-x)))
 198
 199 ;;;###autoload
 200 (defun every (cl-pred cl-seq &rest cl-rest)
 201   "Return true if PREDICATE is true of every element of SEQ or SEQs.
 202 \n(fn PREDICATE SEQ...)"
 203   (if (or cl-rest (nlistp cl-seq))
 204       (catch 'cl-every
 205         (apply 'map nil
 206                (function (lambda (&rest cl-x)
 207                            (or (apply cl-pred cl-x) (throw 'cl-every nil))))
 208                cl-seq cl-rest) t)
 209     (while (and cl-seq (funcall cl-pred (car cl-seq)))
 210       (setq cl-seq (cdr cl-seq)))
 211     (null cl-seq)))
 212
 213 ;;;###autoload
 214 (defun notany (cl-pred cl-seq &rest cl-rest)
 215   "Return true if PREDICATE is false of every element of SEQ or SEQs.
 216 \n(fn PREDICATE SEQ...)"
 217   (not (apply 'some cl-pred cl-seq cl-rest)))
 218
 219 ;;;###autoload
 220 (defun notevery (cl-pred cl-seq &rest cl-rest)
 221   "Return true if PREDICATE is false of some element of SEQ or SEQs.
 222 \n(fn PREDICATE SEQ...)"
 223   (not (apply 'every cl-pred cl-seq cl-rest)))
 224
 225 ;;; Support for `loop'.
 226 ;;;###autoload
 227 (defalias 'cl-map-keymap 'map-keymap)
 228
 229 ;;;###autoload
 230 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
 231   (or cl-base
 232       (setq cl-base (copy-sequence [0])))
 233   (map-keymap
 234    (function
 235     (lambda (cl-key cl-bind)
 236       (aset cl-base (1- (length cl-base)) cl-key)
 237       (if (keymapp cl-bind)
 238           (cl-map-keymap-recursively
 239            cl-func-rec cl-bind
 240            (vconcat cl-base (list 0)))
 241         (funcall cl-func-rec cl-base cl-bind))))
 242    cl-map))
 243
 244 ;;;###autoload
 245 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
 246   (or cl-what (setq cl-what (current-buffer)))
 247   (if (bufferp cl-what)
 248       (let (cl-mark cl-mark2 (cl-next t) cl-next2)
 249         (with-current-buffer cl-what
 250           (setq cl-mark (copy-marker (or cl-start (point-min))))
 251           (setq cl-mark2 (and cl-end (copy-marker cl-end))))
 252         (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
 253           (setq cl-next (if cl-prop (next-single-property-change
 254                                      cl-mark cl-prop cl-what)
 255                           (next-property-change cl-mark cl-what))
 256                 cl-next2 (or cl-next (with-current-buffer cl-what
 257                                        (point-max))))
 258           (funcall cl-func (prog1 (marker-position cl-mark)
 259                              (set-marker cl-mark cl-next2))
 260                    (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
 261         (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
 262     (or cl-start (setq cl-start 0))
 263     (or cl-end (setq cl-end (length cl-what)))
 264     (while (< cl-start cl-end)
 265       (let ((cl-next (or (if cl-prop (next-single-property-change
 266                                       cl-start cl-prop cl-what)
 267                            (next-property-change cl-start cl-what))
 268                          cl-end)))
 269         (funcall cl-func cl-start (min cl-next cl-end))
 270         (setq cl-start cl-next)))))
 271
 272 ;;;###autoload
 273 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
 274   (or cl-buffer (setq cl-buffer (current-buffer)))
 275   (if (fboundp 'overlay-lists)
 276
 277       ;; This is the preferred algorithm, though overlay-lists is undocumented.
 278       (let (cl-ovl)
 279         (with-current-buffer cl-buffer
 280           (setq cl-ovl (overlay-lists))
 281           (if cl-start (setq cl-start (copy-marker cl-start)))
 282           (if cl-end (setq cl-end (copy-marker cl-end))))
 283         (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
 284         (while (and cl-ovl
 285                     (or (not (overlay-start (car cl-ovl)))
 286                         (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
 287                         (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
 288                         (not (funcall cl-func (car cl-ovl) cl-arg))))
 289           (setq cl-ovl (cdr cl-ovl)))
 290         (if cl-start (set-marker cl-start nil))
 291         (if cl-end (set-marker cl-end nil)))
 292
 293     ;; This alternate algorithm fails to find zero-length overlays.
 294     (let ((cl-mark (with-current-buffer cl-buffer
 295                      (copy-marker (or cl-start (point-min)))))
 296           (cl-mark2 (and cl-end (with-current-buffer cl-buffer
 297                                   (copy-marker cl-end))))
 298           cl-pos cl-ovl)
 299       (while (save-excursion
 300                (and (setq cl-pos (marker-position cl-mark))
 301                     (< cl-pos (or cl-mark2 (point-max)))
 302                     (progn
 303                       (set-buffer cl-buffer)
 304                       (setq cl-ovl (overlays-at cl-pos))
 305                       (set-marker cl-mark (next-overlay-change cl-pos)))))
 306         (while (and cl-ovl
 307                     (or (/= (overlay-start (car cl-ovl)) cl-pos)
 308                         (not (and (funcall cl-func (car cl-ovl) cl-arg)
 309                                   (set-marker cl-mark nil)))))
 310           (setq cl-ovl (cdr cl-ovl))))
 311       (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
 312
 313 ;;; Support for `setf'.
 314 ;;;###autoload
 315 (defun cl-set-frame-visible-p (frame val)
 316   (cond ((null val) (make-frame-invisible frame))
 317         ((eq val 'icon) (iconify-frame frame))
 318         (t (make-frame-visible frame)))
 319   val)
 320
 321 ;;; Support for `progv'.
 322 (defvar cl-progv-save)
 323 ;;;###autoload
 324 (defun cl-progv-before (syms values)
 325   (while syms
 326     (push (if (boundp (car syms))
 327                  (cons (car syms) (symbol-value (car syms)))
 328                (car syms)) cl-progv-save)
 329     (if values
 330         (set (pop syms) (pop values))
 331       (makunbound (pop syms)))))
 332
 333 (defun cl-progv-after ()
 334   (while cl-progv-save
 335     (if (consp (car cl-progv-save))
 336         (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
 337       (makunbound (car cl-progv-save)))
 338     (pop cl-progv-save)))
 339
 340
 341 ;;; Numbers.
 342
 343 ;;;###autoload
 344 (defun gcd (&rest args)
 345   "Return the greatest common divisor of the arguments."
 346   (let ((a (abs (or (pop args) 0))))
 347     (while args
 348       (let ((b (abs (pop args))))
 349         (while (> b 0) (setq b (% a (setq a b))))))
 350     a))
 351
 352 ;;;###autoload
 353 (defun lcm (&rest args)
 354   "Return the least common multiple of the arguments."
 355   (if (memq 0 args)
 356       0
 357     (let ((a (abs (or (pop args) 1))))
 358       (while args
 359         (let ((b (abs (pop args))))
 360           (setq a (* (/ a (gcd a b)) b))))
 361       a)))
 362
 363 ;;;###autoload
 364 (defun isqrt (x)
 365   "Return the integer square root of the argument."
 366   (if (and (integerp x) (> x 0))
 367       (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100)
 368                      ((<= x 1000000) 1000) (t x)))
 369             g2)
 370         (while (< (setq g2 (/ (+ g (/ x g)) 2)) g)
 371           (setq g g2))
 372         g)
 373     (if (eq x 0) 0 (signal 'arith-error nil))))
 374
 375 ;;;###autoload
 376 (defun floor* (x &optional y)
 377   "Return a list of the floor of X and the fractional part of X.
 378 With two arguments, return floor and remainder of their quotient."
 379   (let ((q (floor x y)))
 380     (list q (- x (if y (* y q) q)))))
 381
 382 ;;;###autoload
 383 (defun ceiling* (x &optional y)
 384   "Return a list of the ceiling of X and the fractional part of X.
 385 With two arguments, return ceiling and remainder of their quotient."
 386   (let ((res (floor* x y)))
 387     (if (= (car (cdr res)) 0) res
 388       (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
 389
 390 ;;;###autoload
 391 (defun truncate* (x &optional y)
 392   "Return a list of the integer part of X and the fractional part of X.
 393 With two arguments, return truncation and remainder of their quotient."
 394   (if (eq (>= x 0) (or (null y) (>= y 0)))
 395       (floor* x y) (ceiling* x y)))
 396
 397 ;;;###autoload
 398 (defun round* (x &optional y)
 399   "Return a list of X rounded to the nearest integer and the remainder.
 400 With two arguments, return rounding and remainder of their quotient."
 401   (if y
 402       (if (and (integerp x) (integerp y))
 403           (let* ((hy (/ y 2))
 404                  (res (floor* (+ x hy) y)))
 405             (if (and (= (car (cdr res)) 0)
 406                      (= (+ hy hy) y)
 407                      (/= (% (car res) 2) 0))
 408                 (list (1- (car res)) hy)
 409               (list (car res) (- (car (cdr res)) hy))))
 410         (let ((q (round (/ x y))))
 411           (list q (- x (* q y)))))
 412     (if (integerp x) (list x 0)
 413       (let ((q (round x)))
 414         (list q (- x q))))))
 415
 416 ;;;###autoload
 417 (defun mod* (x y)
 418   "The remainder of X divided by Y, with the same sign as Y."
 419   (nth 1 (floor* x y)))
 420
 421 ;;;###autoload
 422 (defun rem* (x y)
 423   "The remainder of X divided by Y, with the same sign as X."
 424   (nth 1 (truncate* x y)))
 425
 426 ;;;###autoload
 427 (defun signum (x)
 428   "Return 1 if X is positive, -1 if negative, 0 if zero."
 429   (cond ((> x 0) 1) ((< x 0) -1) (t 0)))
 430
 431
 432 ;; Random numbers.
 433
 434 (defvar *random-state*)
 435 ;;;###autoload
 436 (defun random* (lim &optional state)
 437   "Return a random nonnegative number less than LIM, an integer or float.
 438 Optional second arg STATE is a random-state object."
 439   (or state (setq state *random-state*))
 440   ;; Inspired by "ran3" from Numerical Recipes.  Additive congruential method.
 441   (let ((vec (aref state 3)))
 442     (if (integerp vec)
 443         (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1))
 444           (aset state 3 (setq vec (make-vector 55 nil)))
 445           (aset vec 0 j)
 446           (while (> (setq i (% (+ i 21) 55)) 0)
 447             (aset vec i (setq j (prog1 k (setq k (- j k))))))
 448           (while (< (setq i (1+ i)) 200) (random* 2 state))))
 449     (let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
 450            (j (aset state 2 (% (1+ (aref state 2)) 55)))
 451            (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
 452       (if (integerp lim)
 453           (if (<= lim 512) (% n lim)
 454             (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state))))
 455             (let ((mask 1023))
 456               (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
 457               (if (< (setq n (logand n mask)) lim) n (random* lim state))))
 458         (* (/ n '8388608e0) lim)))))
 459
 460 ;;;###autoload
 461 (defun make-random-state (&optional state)
 462   "Return a copy of random-state STATE, or of `*random-state*' if omitted.
 463 If STATE is t, return a new state object seeded from the time of day."
 464   (cond ((null state) (make-random-state *random-state*))
 465         ((vectorp state) (cl-copy-tree state t))
 466         ((integerp state) (vector 'cl-random-state-tag -1 30 state))
 467         (t (make-random-state (cl-random-time)))))
 468
 469 ;;;###autoload
 470 (defun random-state-p (object)
 471   "Return t if OBJECT is a random-state object."
 472   (and (vectorp object) (= (length object) 4)
 473        (eq (aref object 0) 'cl-random-state-tag)))
 474
 475
 476 ;; Implementation limits.
 477
 478 (defun cl-finite-do (func a b)
 479   (condition-case err
 480       (let ((res (funcall func a b)))   ; check for IEEE infinity
 481         (and (numberp res) (/= res (/ res 2)) res))
 482     (arith-error nil)))
 483
 484 (defvar most-positive-float)
 485 (defvar most-negative-float)
 486 (defvar least-positive-float)
 487 (defvar least-negative-float)
 488 (defvar least-positive-normalized-float)
 489 (defvar least-negative-normalized-float)
 490 (defvar float-epsilon)
 491 (defvar float-negative-epsilon)
 492
 493 ;;;###autoload
 494 (defun cl-float-limits ()
 495   (or most-positive-float (not (numberp '2e1))
 496       (let ((x '2e0) y z)
 497         ;; Find maximum exponent (first two loops are optimizations)
 498         (while (cl-finite-do '* x x) (setq x (* x x)))
 499         (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
 500         (while (cl-finite-do '+ x x) (setq x (+ x x)))
 501         (setq z x y (/ x 2))
 502         ;; Now fill in 1's in the mantissa.
 503         (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
 504           (setq x (+ x y) y (/ y 2)))
 505         (setq most-positive-float x
 506               most-negative-float (- x))
 507         ;; Divide down until mantissa starts rounding.
 508         (setq x (/ x z) y (/ 16 z) x (* x y))
 509         (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
 510                  (arith-error nil))
 511           (setq x (/ x 2) y (/ y 2)))
 512         (setq least-positive-normalized-float y
 513               least-negative-normalized-float (- y))
 514         ;; Divide down until value underflows to zero.
 515         (setq x (/ 1 z) y x)
 516         (while (condition-case err (> (/ x 2) 0) (arith-error nil))
 517           (setq x (/ x 2)))
 518         (setq least-positive-float x
 519               least-negative-float (- x))
 520         (setq x '1e0)
 521         (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
 522         (setq float-epsilon (* x 2))
 523         (setq x '1e0)
 524         (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
 525         (setq float-negative-epsilon (* x 2))))
 526   nil)
 527
 528
 529 ;;; Sequence functions.
 530
 531 ;;;###autoload
 532 (defun subseq (seq start &optional end)
 533   "Return the subsequence of SEQ from START to END.
 534 If END is omitted, it defaults to the length of the sequence.
 535 If START or END is negative, it counts from the end."
 536   (if (stringp seq) (substring seq start end)
 537     (let (len)
 538       (and end (< end 0) (setq end (+ end (setq len (length seq)))))
 539       (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
 540       (cond ((listp seq)
 541              (if (> start 0) (setq seq (nthcdr start seq)))
 542              (if end
 543                  (let ((res nil))
 544                    (while (>= (setq end (1- end)) start)
 545                      (push (pop seq) res))
 546                    (nreverse res))
 547                (copy-sequence seq)))
 548             (t
 549              (or end (setq end (or len (length seq))))
 550              (let ((res (make-vector (max (- end start) 0) nil))
 551                    (i 0))
 552                (while (< start end)
 553                  (aset res i (aref seq start))
 554                  (setq i (1+ i) start (1+ start)))
 555                res))))))
 556
 557 ;;;###autoload
 558 (defun concatenate (type &rest seqs)
 559   "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
 560 \n(fn TYPE SEQUENCE...)"
 561   (cond ((eq type 'vector) (apply 'vconcat seqs))
 562         ((eq type 'string) (apply 'concat seqs))
 563         ((eq type 'list) (apply 'append (append seqs '(nil))))
 564         (t (error "Not a sequence type name: %s" type))))
 565
 566
 567 ;;; List functions.
 568
 569 ;;;###autoload
 570 (defun revappend (x y)
 571   "Equivalent to (append (reverse X) Y)."
 572   (nconc (reverse x) y))
 573
 574 ;;;###autoload
 575 (defun nreconc (x y)
 576   "Equivalent to (nconc (nreverse X) Y)."
 577   (nconc (nreverse x) y))
 578
 579 ;;;###autoload
 580 (defun list-length (x)
 581   "Return the length of list X.  Return nil if list is circular."
 582   (let ((n 0) (fast x) (slow x))
 583     (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
 584       (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
 585     (if fast (if (cdr fast) nil (1+ n)) n)))
 586
 587 ;;;###autoload
 588 (defun tailp (sublist list)
 589   "Return true if SUBLIST is a tail of LIST."
 590   (while (and (consp list) (not (eq sublist list)))
 591     (setq list (cdr list)))
 592   (if (numberp sublist) (equal sublist list) (eq sublist list)))
 593
 594 (defalias 'cl-copy-tree 'copy-tree)
 595
 596
 597 ;;; Property lists.
 598
 599 ;;;###autoload
 600 (defun get* (sym tag &optional def)    ; See compiler macro in cl-macs.el
 601   "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
 602 \n(fn SYMBOL PROPNAME &optional DEFAULT)"
 603   (or (get sym tag)
 604       (and def
 605            (let ((plist (symbol-plist sym)))
 606              (while (and plist (not (eq (car plist) tag)))
 607                (setq plist (cdr (cdr plist))))
 608              (if plist (car (cdr plist)) def)))))
 609
 610 ;;;###autoload
 611 (defun getf (plist tag &optional def)
 612   "Search PROPLIST for property PROPNAME; return its value or DEFAULT.
 613 PROPLIST is a list of the sort returned by `symbol-plist'.
 614 \n(fn PROPLIST PROPNAME &optional DEFAULT)"
 615   (setplist '--cl-getf-symbol-- plist)
 616   (or (get '--cl-getf-symbol-- tag)
 617       ;; Originally we called get* here,
 618       ;; but that fails, because get* has a compiler macro
 619       ;; definition that uses getf!
 620       (when def
 621         (while (and plist (not (eq (car plist) tag)))
 622           (setq plist (cdr (cdr plist))))
 623         (if plist (car (cdr plist)) def))))
 624
 625 ;;;###autoload
 626 (defun cl-set-getf (plist tag val)
 627   (let ((p plist))
 628     (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
 629     (if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
 630
 631 ;;;###autoload
 632 (defun cl-do-remf (plist tag)
 633   (let ((p (cdr plist)))
 634     (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
 635     (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
 636
 637 ;;;###autoload
 638 (defun cl-remprop (sym tag)
 639   "Remove from SYMBOL's plist the property PROPNAME and its value.
 640 \n(fn SYMBOL PROPNAME)"
 641   (let ((plist (symbol-plist sym)))
 642     (if (and plist (eq tag (car plist)))
 643         (progn (setplist sym (cdr (cdr plist))) t)
 644       (cl-do-remf plist tag))))
 645 ;;;###autoload
 646 (defalias 'remprop 'cl-remprop)
 647
 648
 649
 650 ;;; Hash tables.
 651 ;; This is just kept for compatibility with code byte-compiled by Emacs-20.
 652
 653 ;; No idea if this might still be needed.
 654 (defun cl-not-hash-table (x &optional y &rest z)
 655   (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x))))
 656
 657 (defvar cl-builtin-gethash (symbol-function 'gethash))
 658 (defvar cl-builtin-remhash (symbol-function 'remhash))
 659 (defvar cl-builtin-clrhash (symbol-function 'clrhash))
 660 (defvar cl-builtin-maphash (symbol-function 'maphash))
 661
 662 ;;;###autoload
 663 (defalias 'cl-gethash 'gethash)
 664 ;;;###autoload
 665 (defalias 'cl-puthash 'puthash)
 666 ;;;###autoload
 667 (defalias 'cl-remhash 'remhash)
 668 ;;;###autoload
 669 (defalias 'cl-clrhash 'clrhash)
 670 ;;;###autoload
 671 (defalias 'cl-maphash 'maphash)
 672 ;; These three actually didn't exist in Emacs-20.
 673 ;;;###autoload
 674 (defalias 'cl-make-hash-table 'make-hash-table)
 675 ;;;###autoload
 676 (defalias 'cl-hash-table-p 'hash-table-p)
 677 ;;;###autoload
 678 (defalias 'cl-hash-table-count 'hash-table-count)
 679
 680 ;;; Some debugging aids.
 681
 682 (defun cl-prettyprint (form)
 683   "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
 684   (let ((pt (point)) last)
 685     (insert "\n" (prin1-to-string form) "\n")
 686     (setq last (point))
 687     (goto-char (1+ pt))
 688     (while (search-forward "(quote " last t)
 689       (delete-char -7)
 690       (insert "'")
 691       (forward-sexp)
 692       (delete-char 1))
 693     (goto-char (1+ pt))
 694     (cl-do-prettyprint)))
 695
 696 (defun cl-do-prettyprint ()
 697   (skip-chars-forward " ")
 698   (if (looking-at "(")
 699       (let ((skip (or (looking-at "((") (looking-at "(prog")
 700                       (looking-at "(unwind-protect ")
 701                       (looking-at "(function (")
 702                       (looking-at "(cl-block-wrapper ")))
 703             (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
 704             (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
 705             (set (looking-at "(p?set[qf] ")))
 706         (if (or skip let
 707                 (progn
 708                   (forward-sexp)
 709                   (and (>= (current-column) 78) (progn (backward-sexp) t))))
 710             (let ((nl t))
 711               (forward-char 1)
 712               (cl-do-prettyprint)
 713               (or skip (looking-at ")") (cl-do-prettyprint))
 714               (or (not two) (looking-at ")") (cl-do-prettyprint))
 715               (while (not (looking-at ")"))
 716                 (if set (setq nl (not nl)))
 717                 (if nl (insert "\n"))
 718                 (lisp-indent-line)
 719                 (cl-do-prettyprint))
 720               (forward-char 1))))
 721     (forward-sexp)))
 722
 723 (defvar cl-macroexpand-cmacs nil)
 724 (defvar cl-closure-vars nil)
 725
 726 ;;;###autoload
 727 (defun cl-macroexpand-all (form &optional env)
 728   "Expand all macro calls through a Lisp FORM.
 729 This also does some trivial optimizations to make the form prettier."
 730   (while (or (not (eq form (setq form (macroexpand form env))))
 731              (and cl-macroexpand-cmacs
 732                   (not (eq form (setq form (compiler-macroexpand form)))))))
 733   (cond ((not (consp form)) form)
 734         ((memq (car form) '(let let*))
 735          (if (null (nth 1 form))
 736              (cl-macroexpand-all (cons 'progn (cddr form)) env)
 737            (let ((letf nil) (res nil) (lets (cadr form)))
 738              (while lets
 739                (push (if (consp (car lets))
 740                             (let ((exp (cl-macroexpand-all (caar lets) env)))
 741                               (or (symbolp exp) (setq letf t))
 742                               (cons exp (cl-macroexpand-body (cdar lets) env)))
 743                           (let ((exp (cl-macroexpand-all (car lets) env)))
 744                             (if (symbolp exp) exp
 745                               (setq letf t) (list exp nil)))) res)
 746                (setq lets (cdr lets)))
 747              (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
 748                     (nreverse res) (cl-macroexpand-body (cddr form) env)))))
 749         ((eq (car form) 'cond)
 750          (cons (car form)
 751                (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
 752                        (cdr form))))
 753         ((eq (car form) 'condition-case)
 754          (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
 755                 (mapcar (function
 756                          (lambda (x)
 757                            (cons (car x) (cl-macroexpand-body (cdr x) env))))
 758                         (cdddr form))))
 759         ((memq (car form) '(quote function))
 760          (if (eq (car-safe (nth 1 form)) 'lambda)
 761              (let ((body (cl-macroexpand-body (cddadr form) env)))
 762                (if (and cl-closure-vars (eq (car form) 'function)
 763                         (cl-expr-contains-any body cl-closure-vars))
 764                    (let* ((new (mapcar 'gensym cl-closure-vars))
 765                           (sub (pairlis cl-closure-vars new)) (decls nil))
 766                      (while (or (stringp (car body))
 767                                 (eq (car-safe (car body)) 'interactive))
 768                        (push (list 'quote (pop body)) decls))
 769                      (put (car (last cl-closure-vars)) 'used t)
 770                      (append
 771                       (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
 772                       (sublis sub (nreverse decls))
 773                       (list
 774                        (list* 'list '(quote apply)
 775                               (list 'function
 776                                     (list* 'lambda
 777                                            (append new (cadadr form))
 778                                            (sublis sub body)))
 779                               (nconc (mapcar (function
 780                                               (lambda (x)
 781                                                 (list 'list '(quote quote) x)))
 782                                              cl-closure-vars)
 783                                      '((quote --cl-rest--)))))))
 784                  (list (car form) (list* 'lambda (cadadr form) body))))
 785            (let ((found (assq (cadr form) env)))
 786              (if (and found (ignore-errors
 787                               (eq (cadr (caddr found)) 'cl-labels-args)))
 788                  (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
 789                form))))
 790         ((memq (car form) '(defun defmacro))
 791          (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
 792         ((and (eq (car form) 'progn) (not (cddr form)))
 793          (cl-macroexpand-all (nth 1 form) env))
 794         ((eq (car form) 'setq)
 795          (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
 796            (while (and p (symbolp (car p))) (setq p (cddr p)))
 797            (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
 798         ((consp (car form))
 799          (cl-macroexpand-all (list* 'funcall
 800                                     (list 'function (car form))
 801                                     (cdr form))
 802                              env))
 803         (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
 804
 805 (defun cl-macroexpand-body (body &optional env)
 806   (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
 807
 808 ;;;###autoload
 809 (defun cl-prettyexpand (form &optional full)
 810   (message "Expanding...")
 811   (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
 812         (byte-compile-macro-environment nil))
 813     (setq form (cl-macroexpand-all form
 814                                    (and (not full) '((block) (eval-when)))))
 815     (message "Formatting...")
 816     (prog1 (cl-prettyprint form)
 817       (message ""))))
 818
 819
 820
 821 (run-hooks 'cl-extra-load-hook)
 822
 823 ;; Local variables:
 824 ;; byte-compile-dynamic: t
 825 ;; byte-compile-warnings: (not cl-functions)
 826 ;; generated-autoload-file: "cl-loaddefs.el"
 827 ;; End:
 828
 829 ;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
 830 ;;; cl-extra.el ends here