lisp/emacs-lisp/cl-lib.el

   1 ;;; cl-lib.el --- Common Lisp extensions for Emacs  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 1993, 2001-2012  Free Software Foundation, Inc.
   4
   5 ;; Author: Dave Gillespie <daveg@synaptics.com>
   6 ;; Version: 2.02
   7 ;; Keywords: extensions
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; These are extensions to Emacs Lisp that provide a degree of
  27 ;; Common Lisp compatibility, beyond what is already built-in
  28 ;; in Emacs Lisp.
  29 ;;
  30 ;; This package was written by Dave Gillespie; it is a complete
  31 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
  32 ;;
  33 ;; Bug reports, comments, and suggestions are welcome!
  34
  35 ;; This file contains the portions of the Common Lisp extensions
  36 ;; package which should always be present.
  37
  38
  39 ;;; Future notes:
  40
  41 ;; Once Emacs 19 becomes standard, many things in this package which are
  42 ;; messy for reasons of compatibility can be greatly simplified.  For now,
  43 ;; I prefer to maintain one unified version.
  44
  45
  46 ;;; Change Log:
  47
  48 ;; Version 2.02 (30 Jul 93):
  49 ;;  * Added "cl-compat.el" file, extra compatibility with old package.
  50 ;;  * Added `lexical-let' and `lexical-let*'.
  51 ;;  * Added `define-modify-macro', `callf', and `callf2'.
  52 ;;  * Added `ignore-errors'.
  53 ;;  * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero.
  54 ;;  * Merged `*gentemp-counter*' into `*gensym-counter*'.
  55 ;;  * Extended `subseq' to allow negative START and END like `substring'.
  56 ;;  * Added `in-ref', `across-ref', `elements of-ref' loop clauses.
  57 ;;  * Added `concat', `vconcat' loop clauses.
  58 ;;  * Cleaned up a number of compiler warnings.
  59
  60 ;; Version 2.01 (7 Jul 93):
  61 ;;  * Added support for FSF version of Emacs 19.
  62 ;;  * Added `add-hook' for Emacs 18 users.
  63 ;;  * Added `defsubst*' and `symbol-macrolet'.
  64 ;;  * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'.
  65 ;;  * Added `map', `concatenate', `reduce', `merge'.
  66 ;;  * Added `revappend', `nreconc', `tailp', `tree-equal'.
  67 ;;  * Added `assert', `check-type', `typecase', `typep', and `deftype'.
  68 ;;  * Added destructuring and `&environment' support to `defmacro*'.
  69 ;;  * Added destructuring to `loop', and added the following clauses:
  70 ;;      `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'.
  71 ;;  * Renamed `delete' to `delete*' and `remove' to `remove*'.
  72 ;;  * Completed support for all keywords in `remove*', `substitute', etc.
  73 ;;  * Added `most-positive-float' and company.
  74 ;;  * Fixed hash tables to work with latest Lucid Emacs.
  75 ;;  * `proclaim' forms are no longer compile-time-evaluating; use `declaim'.
  76 ;;  * Syntax for `warn' declarations has changed.
  77 ;;  * Improved implementation of `random*'.
  78 ;;  * Moved most sequence functions to a new file, cl-seq.el.
  79 ;;  * Moved `eval-when' into cl-macs.el.
  80 ;;  * Moved `pushnew' and `adjoin' to cl.el for most common cases.
  81 ;;  * Moved `provide' forms down to ends of files.
  82 ;;  * Changed expansion of `pop' to something that compiles to better code.
  83 ;;  * Changed so that no patch is required for Emacs 19 byte compiler.
  84 ;;  * Made more things dependent on `optimize' declarations.
  85 ;;  * Added a partial implementation of struct print functions.
  86 ;;  * Miscellaneous minor changes.
  87
  88 ;; Version 2.00:
  89 ;;  * First public release of this package.
  90
  91
  92 ;;; Code:
  93
  94 (defvar cl-optimize-speed 1)
  95 (defvar cl-optimize-safety 1)
  96
  97 ;;;###autoload
  98 (define-obsolete-variable-alias
  99   ;; This alias is needed for compatibility with .elc files that use defstruct
 100   ;; and were compiled with Emacs<24.2.
 101   'custom-print-functions 'cl-custom-print-functions "24.2")
 102
 103 ;;;###autoload
 104 (defvar cl-custom-print-functions nil
 105   "This is a list of functions that format user objects for printing.
 106 Each function is called in turn with three arguments: the object, the
 107 stream, and the print level (currently ignored).  If it is able to
 108 print the object it returns true; otherwise it returns nil and the
 109 printer proceeds to the next function on the list.
 110
 111 This variable is not used at present, but it is defined in hopes that
 112 a future Emacs interpreter will be able to use it.")
 113
 114 (defun cl-unload-function ()
 115   "Stop unloading of the Common Lisp extensions."
 116   (message "Cannot unload the feature `cl'")
 117   ;; Stop standard unloading!
 118   t)
 119
 120 ;;; Generalized variables.
 121 ;; These macros are defined here so that they
 122 ;; can safely be used in .emacs files.
 123
 124 (defmacro cl-incf (place &optional x)
 125   "Increment PLACE by X (1 by default).
 126 PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
 127 The return value is the incremented value of PLACE."
 128   (declare (debug (place &optional form)))
 129   (if (symbolp place)
 130       (list 'setq place (if x (list '+ place x) (list '1+ place)))
 131     (list 'cl-callf '+ place (or x 1))))
 132
 133 (defmacro cl-decf (place &optional x)
 134   "Decrement PLACE by X (1 by default).
 135 PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
 136 The return value is the decremented value of PLACE."
 137   (declare (debug cl-incf))
 138   (if (symbolp place)
 139       (list 'setq place (if x (list '- place x) (list '1- place)))
 140     (list 'cl-callf '- place (or x 1))))
 141
 142 ;; Autoloaded, but we haven't loaded cl-loaddefs yet.
 143 (declare-function cl-do-pop "cl-macs" (place))
 144
 145 (defmacro cl-pop (place)
 146   "Remove and return the head of the list stored in PLACE.
 147 Analogous to (prog1 (car PLACE) (cl-setf PLACE (cdr PLACE))), though more
 148 careful about evaluating each argument only once and in the right order.
 149 PLACE may be a symbol, or any generalized variable allowed by `cl-setf'."
 150   (declare (debug (place)))
 151   (if (symbolp place)
 152       (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))
 153     (cl-do-pop place)))
 154
 155 (defmacro cl-push (x place)
 156   "Insert X at the head of the list stored in PLACE.
 157 Analogous to (cl-setf PLACE (cons X PLACE)), though more careful about
 158 evaluating each argument only once and in the right order.  PLACE may
 159 be a symbol, or any generalized variable allowed by `cl-setf'."
 160   (declare (debug (form place)))
 161   (if (symbolp place) (list 'setq place (list 'cons x place))
 162     (list 'cl-callf2 'cons x place)))
 163
 164 (defmacro cl-pushnew (x place &rest keys)
 165   "(cl-pushnew X PLACE): insert X at the head of the list if not already there.
 166 Like (cl-push X PLACE), except that the list is unmodified if X is `eql' to
 167 an element already on the list.
 168 \nKeywords supported:  :test :test-not :key
 169 \n(fn X PLACE [KEYWORD VALUE]...)"
 170   (declare (debug
 171             (form place &rest
 172                   &or [[&or ":test" ":test-not" ":key"] function-form]
 173                   [keywordp form])))
 174   (if (symbolp place)
 175       (if (null keys)
 176           `(let ((x ,x))
 177              (if (memql x ,place)
 178                  ;; This symbol may later on expand to actual code which then
 179                  ;; trigger warnings like "value unused" since cl-pushnew's return
 180                  ;; value is rarely used.  It should not matter that other
 181                  ;; warnings may be silenced, since `place' is used earlier and
 182                  ;; should have triggered them already.
 183                  (with-no-warnings ,place)
 184                (setq ,place (cons x ,place))))
 185         (list 'setq place (cl-list* 'cl-adjoin x place keys)))
 186     (cl-list* 'cl-callf2 'cl-adjoin x place keys)))
 187
 188 (defun cl--set-elt (seq n val)
 189   (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
 190
 191 (defsubst cl--set-nthcdr (n list x)
 192   (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
 193
 194 (defun cl--set-buffer-substring (start end val)
 195   (save-excursion (delete-region start end)
 196                   (goto-char start)
 197                   (insert val)
 198                   val))
 199
 200 (defun cl--set-substring (str start end val)
 201   (if end (if (< end 0) (cl-incf end (length str)))
 202     (setq end (length str)))
 203   (if (< start 0) (cl-incf start (length str)))
 204   (concat (and (> start 0) (substring str 0 start))
 205           val
 206           (and (< end (length str)) (substring str end))))
 207
 208
 209 ;;; Blocks and exits.
 210
 211 (defalias 'cl--block-wrapper 'identity)
 212 (defalias 'cl--block-throw 'throw)
 213
 214
 215 ;;; Multiple values.
 216 ;; True multiple values are not supported, or even
 217 ;; simulated.  Instead, cl-multiple-value-bind and friends simply expect
 218 ;; the target form to return the values as a list.
 219
 220 (defun cl--defalias (cl-f el-f &optional doc)
 221   (defalias cl-f el-f doc)
 222   (put cl-f 'byte-optimizer 'byte-compile-inline-expand))
 223
 224 (cl--defalias 'cl-values #'list
 225   "Return multiple values, Common Lisp style.
 226 The arguments of `cl-values' are the values
 227 that the containing function should return.
 228
 229 \(fn &rest VALUES)")
 230
 231 (cl--defalias 'cl-values-list #'identity
 232   "Return multiple values, Common Lisp style, taken from a list.
 233 LIST specifies the list of values
 234 that the containing function should return.
 235
 236 \(fn LIST)")
 237
 238 (defsubst cl-multiple-value-list (expression)
 239   "Return a list of the multiple values produced by EXPRESSION.
 240 This handles multiple values in Common Lisp style, but it does not
 241 work right when EXPRESSION calls an ordinary Emacs Lisp function
 242 that returns just one value."
 243   expression)
 244
 245 (defsubst cl-multiple-value-apply (function expression)
 246   "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them.
 247 This handles multiple values in Common Lisp style, but it does not work
 248 right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
 249 one value."
 250   (apply function expression))
 251
 252 (defalias 'cl-multiple-value-call 'apply
 253   "Apply FUNCTION to ARGUMENTS, taking multiple values into account.
 254 This implementation only handles the case where there is only one argument.")
 255
 256 (defsubst cl-nth-value (n expression)
 257   "Evaluate EXPRESSION to get multiple values and return the Nth one.
 258 This handles multiple values in Common Lisp style, but it does not work
 259 right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
 260 one value."
 261   (nth n expression))
 262
 263 ;;; Declarations.
 264
 265 (defvar cl--compiling-file nil)
 266 (defun cl--compiling-file ()
 267   (or cl--compiling-file
 268       (and (boundp 'byte-compile--outbuffer)
 269            (bufferp (symbol-value 'byte-compile--outbuffer))
 270            (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
 271                   " *Compiler Output*"))))
 272
 273 (defvar cl-proclaims-deferred nil)
 274
 275 (defun cl-proclaim (spec)
 276   (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
 277     (push spec cl-proclaims-deferred))
 278   nil)
 279
 280 (defmacro cl-declaim (&rest specs)
 281   (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x))))
 282                       specs)))
 283     (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
 284       (cons 'progn body))))   ; avoid loading cl-macs.el for cl-eval-when
 285
 286
 287 ;;; Symbols.
 288
 289 (defun cl-random-time ()
 290   (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
 291     (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
 292     v))
 293
 294 (defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100))
 295
 296
 297 ;;; Numbers.
 298
 299 (defun cl-floatp-safe (object)
 300   "Return t if OBJECT is a floating point number.
 301 On Emacs versions that lack floating-point support, this function
 302 always returns nil."
 303   (and (numberp object) (not (integerp object))))
 304
 305 (defsubst cl-plusp (number)
 306   "Return t if NUMBER is positive."
 307   (> number 0))
 308
 309 (defsubst cl-minusp (number)
 310   "Return t if NUMBER is negative."
 311   (< number 0))
 312
 313 (defun cl-oddp (integer)
 314   "Return t if INTEGER is odd."
 315   (eq (logand integer 1) 1))
 316
 317 (defun cl-evenp (integer)
 318   "Return t if INTEGER is even."
 319   (eq (logand integer 1) 0))
 320
 321 (defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time)))
 322
 323 (defconst cl-most-positive-float nil
 324   "The largest value that a Lisp float can hold.
 325 If your system supports infinities, this is the largest finite value.
 326 For IEEE machines, this is approximately 1.79e+308.
 327 Call `cl-float-limits' to set this.")
 328
 329 (defconst cl-most-negative-float nil
 330   "The largest negative value that a Lisp float can hold.
 331 This is simply -`cl-most-positive-float'.
 332 Call `cl-float-limits' to set this.")
 333
 334 (defconst cl-least-positive-float nil
 335   "The smallest value greater than zero that a Lisp float can hold.
 336 For IEEE machines, it is about 4.94e-324 if denormals are supported,
 337 or 2.22e-308 if they are not.
 338 Call `cl-float-limits' to set this.")
 339
 340 (defconst cl-least-negative-float nil
 341   "The smallest value less than zero that a Lisp float can hold.
 342 This is simply -`cl-least-positive-float'.
 343 Call `cl-float-limits' to set this.")
 344
 345 (defconst cl-least-positive-normalized-float nil
 346   "The smallest normalized Lisp float greater than zero.
 347 This is the smallest value for which IEEE denormalization does not lose
 348 precision.  For IEEE machines, this value is about 2.22e-308.
 349 For machines that do not support the concept of denormalization
 350 and gradual underflow, this constant equals `cl-least-positive-float'.
 351 Call `cl-float-limits' to set this.")
 352
 353 (defconst cl-least-negative-normalized-float nil
 354   "The smallest normalized Lisp float less than zero.
 355 This is simply -`cl-least-positive-normalized-float'.
 356 Call `cl-float-limits' to set this.")
 357
 358 (defconst cl-float-epsilon nil
 359   "The smallest positive float that adds to 1.0 to give a distinct value.
 360 Adding a number less than this to 1.0 returns 1.0 due to roundoff.
 361 For IEEE machines, epsilon is about 2.22e-16.
 362 Call `cl-float-limits' to set this.")
 363
 364 (defconst cl-float-negative-epsilon nil
 365   "The smallest positive float that subtracts from 1.0 to give a distinct value.
 366 For IEEE machines, it is about 1.11e-16.
 367 Call `cl-float-limits' to set this.")
 368
 369
 370 ;;; Sequence functions.
 371
 372 (cl--defalias 'cl-copy-seq 'copy-sequence)
 373
 374 (declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs))
 375
 376 (defun cl-mapcar (cl-func cl-x &rest cl-rest)
 377   "Apply FUNCTION to each element of SEQ, and make a list of the results.
 378 If there are several SEQs, FUNCTION is called with that many arguments,
 379 and mapping stops as soon as the shortest list runs out.  With just one
 380 SEQ, this is like `mapcar'.  With several, it is like the Common Lisp
 381 `mapcar' function extended to arbitrary sequence types.
 382 \n(fn FUNCTION SEQ...)"
 383   (if cl-rest
 384       (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
 385           (cl--mapcar-many cl-func (cons cl-x cl-rest))
 386         (let ((cl-res nil) (cl-y (car cl-rest)))
 387           (while (and cl-x cl-y)
 388             (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
 389           (nreverse cl-res)))
 390     (mapcar cl-func cl-x)))
 391
 392 (cl--defalias 'cl-svref 'aref)
 393
 394 ;;; List functions.
 395
 396 (cl--defalias 'cl-first 'car)
 397 (cl--defalias 'cl-second 'cadr)
 398 (cl--defalias 'cl-rest 'cdr)
 399 (cl--defalias 'cl-endp 'null)
 400
 401 (cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.")
 402 (cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.")
 403
 404 (defsubst cl-fifth (x)
 405   "Return the fifth element of the list X."
 406   (nth 4 x))
 407
 408 (defsubst cl-sixth (x)
 409   "Return the sixth element of the list X."
 410   (nth 5 x))
 411
 412 (defsubst cl-seventh (x)
 413   "Return the seventh element of the list X."
 414   (nth 6 x))
 415
 416 (defsubst cl-eighth (x)
 417   "Return the eighth element of the list X."
 418   (nth 7 x))
 419
 420 (defsubst cl-ninth (x)
 421   "Return the ninth element of the list X."
 422   (nth 8 x))
 423
 424 (defsubst cl-tenth (x)
 425   "Return the tenth element of the list X."
 426   (nth 9 x))
 427
 428 (defun cl-caaar (x)
 429   "Return the `car' of the `car' of the `car' of X."
 430   (declare (compiler-macro cl--compiler-macro-cXXr))
 431   (car (car (car x))))
 432
 433 (defun cl-caadr (x)
 434   "Return the `car' of the `car' of the `cdr' of X."
 435   (declare (compiler-macro cl--compiler-macro-cXXr))
 436   (car (car (cdr x))))
 437
 438 (defun cl-cadar (x)
 439   "Return the `car' of the `cdr' of the `car' of X."
 440   (declare (compiler-macro cl--compiler-macro-cXXr))
 441   (car (cdr (car x))))
 442
 443 (defun cl-caddr (x)
 444   "Return the `car' of the `cdr' of the `cdr' of X."
 445   (declare (compiler-macro cl--compiler-macro-cXXr))
 446   (car (cdr (cdr x))))
 447
 448 (defun cl-cdaar (x)
 449   "Return the `cdr' of the `car' of the `car' of X."
 450   (declare (compiler-macro cl--compiler-macro-cXXr))
 451   (cdr (car (car x))))
 452
 453 (defun cl-cdadr (x)
 454   "Return the `cdr' of the `car' of the `cdr' of X."
 455   (declare (compiler-macro cl--compiler-macro-cXXr))
 456   (cdr (car (cdr x))))
 457
 458 (defun cl-cddar (x)
 459   "Return the `cdr' of the `cdr' of the `car' of X."
 460   (declare (compiler-macro cl--compiler-macro-cXXr))
 461   (cdr (cdr (car x))))
 462
 463 (defun cl-cdddr (x)
 464   "Return the `cdr' of the `cdr' of the `cdr' of X."
 465   (declare (compiler-macro cl--compiler-macro-cXXr))
 466   (cdr (cdr (cdr x))))
 467
 468 (defun cl-caaaar (x)
 469   "Return the `car' of the `car' of the `car' of the `car' of X."
 470   (declare (compiler-macro cl--compiler-macro-cXXr))
 471   (car (car (car (car x)))))
 472
 473 (defun cl-caaadr (x)
 474   "Return the `car' of the `car' of the `car' of the `cdr' of X."
 475   (declare (compiler-macro cl--compiler-macro-cXXr))
 476   (car (car (car (cdr x)))))
 477
 478 (defun cl-caadar (x)
 479   "Return the `car' of the `car' of the `cdr' of the `car' of X."
 480   (declare (compiler-macro cl--compiler-macro-cXXr))
 481   (car (car (cdr (car x)))))
 482
 483 (defun cl-caaddr (x)
 484   "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
 485   (declare (compiler-macro cl--compiler-macro-cXXr))
 486   (car (car (cdr (cdr x)))))
 487
 488 (defun cl-cadaar (x)
 489   "Return the `car' of the `cdr' of the `car' of the `car' of X."
 490   (declare (compiler-macro cl--compiler-macro-cXXr))
 491   (car (cdr (car (car x)))))
 492
 493 (defun cl-cadadr (x)
 494   "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
 495   (declare (compiler-macro cl--compiler-macro-cXXr))
 496   (car (cdr (car (cdr x)))))
 497
 498 (defun cl-caddar (x)
 499   "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
 500   (declare (compiler-macro cl--compiler-macro-cXXr))
 501   (car (cdr (cdr (car x)))))
 502
 503 (defun cl-cadddr (x)
 504   "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
 505   (declare (compiler-macro cl--compiler-macro-cXXr))
 506   (car (cdr (cdr (cdr x)))))
 507
 508 (defun cl-cdaaar (x)
 509   "Return the `cdr' of the `car' of the `car' of the `car' of X."
 510   (declare (compiler-macro cl--compiler-macro-cXXr))
 511   (cdr (car (car (car x)))))
 512
 513 (defun cl-cdaadr (x)
 514   "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
 515   (declare (compiler-macro cl--compiler-macro-cXXr))
 516   (cdr (car (car (cdr x)))))
 517
 518 (defun cl-cdadar (x)
 519   "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
 520   (declare (compiler-macro cl--compiler-macro-cXXr))
 521   (cdr (car (cdr (car x)))))
 522
 523 (defun cl-cdaddr (x)
 524   "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
 525   (declare (compiler-macro cl--compiler-macro-cXXr))
 526   (cdr (car (cdr (cdr x)))))
 527
 528 (defun cl-cddaar (x)
 529   "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
 530   (declare (compiler-macro cl--compiler-macro-cXXr))
 531   (cdr (cdr (car (car x)))))
 532
 533 (defun cl-cddadr (x)
 534   "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
 535   (declare (compiler-macro cl--compiler-macro-cXXr))
 536   (cdr (cdr (car (cdr x)))))
 537
 538 (defun cl-cdddar (x)
 539   "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
 540   (declare (compiler-macro cl--compiler-macro-cXXr))
 541   (cdr (cdr (cdr (car x)))))
 542
 543 (defun cl-cddddr (x)
 544   "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
 545   (declare (compiler-macro cl--compiler-macro-cXXr))
 546   (cdr (cdr (cdr (cdr x)))))
 547
 548 ;;(defun last* (x &optional n)
 549 ;;  "Returns the last link in the list LIST.
 550 ;;With optional argument N, returns Nth-to-last link (default 1)."
 551 ;;  (if n
 552 ;;      (let ((m 0) (p x))
 553 ;;      (while (consp p) (cl-incf m) (pop p))
 554 ;;      (if (<= n 0) p
 555 ;;        (if (< n m) (nthcdr (- m n) x) x)))
 556 ;;    (while (consp (cdr x)) (pop x))
 557 ;;    x))
 558
 559 (defun cl-list* (arg &rest rest)
 560   "Return a new list with specified ARGs as elements, consed to last ARG.
 561 Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
 562 `(cons A (cons B (cons C D)))'.
 563 \n(fn ARG...)"
 564   (declare (compiler-macro cl--compiler-macro-list*))
 565   (cond ((not rest) arg)
 566         ((not (cdr rest)) (cons arg (car rest)))
 567         (t (let* ((n (length rest))
 568                   (copy (copy-sequence rest))
 569                   (last (nthcdr (- n 2) copy)))
 570              (setcdr last (car (cdr last)))
 571              (cons arg copy)))))
 572
 573 (defun cl-ldiff (list sublist)
 574   "Return a copy of LIST with the tail SUBLIST removed."
 575   (let ((res nil))
 576     (while (and (consp list) (not (eq list sublist)))
 577       (push (pop list) res))
 578     (nreverse res)))
 579
 580 (defun cl-copy-list (list)
 581   "Return a copy of LIST, which may be a dotted list.
 582 The elements of LIST are not copied, just the list structure itself."
 583   (if (consp list)
 584       (let ((res nil))
 585         (while (consp list) (push (pop list) res))
 586         (prog1 (nreverse res) (setcdr res list)))
 587     (car list)))
 588
 589 ;; Autoloaded, but we have not loaded cl-loaddefs yet.
 590 (declare-function cl-floor "cl-extra" (x &optional y))
 591 (declare-function cl-ceiling "cl-extra" (x &optional y))
 592 (declare-function cl-truncate "cl-extra" (x &optional y))
 593 (declare-function cl-round "cl-extra" (x &optional y))
 594 (declare-function cl-mod "cl-extra" (x y))
 595
 596 (defun cl-adjoin (cl-item cl-list &rest cl-keys)
 597   "Return ITEM consed onto the front of LIST only if it's not already there.
 598 Otherwise, return LIST unmodified.
 599 \nKeywords supported:  :test :test-not :key
 600 \n(fn ITEM LIST [KEYWORD VALUE]...)"
 601   (declare (compiler-macro cl--compiler-macro-adjoin))
 602   (cond ((or (equal cl-keys '(:test eq))
 603              (and (null cl-keys) (not (numberp cl-item))))
 604          (if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
 605         ((or (equal cl-keys '(:test equal)) (null cl-keys))
 606          (if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
 607         (t (apply 'cl--adjoin cl-item cl-list cl-keys))))
 608
 609 (defun cl-subst (cl-new cl-old cl-tree &rest cl-keys)
 610   "Substitute NEW for OLD everywhere in TREE (non-destructively).
 611 Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
 612 \nKeywords supported:  :test :test-not :key
 613 \n(fn NEW OLD TREE [KEYWORD VALUE]...)"
 614   (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
 615       (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
 616     (cl--do-subst cl-new cl-old cl-tree)))
 617
 618 (defun cl--do-subst (cl-new cl-old cl-tree)
 619   (cond ((eq cl-tree cl-old) cl-new)
 620         ((consp cl-tree)
 621          (let ((a (cl--do-subst cl-new cl-old (car cl-tree)))
 622                (d (cl--do-subst cl-new cl-old (cdr cl-tree))))
 623            (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
 624                cl-tree (cons a d))))
 625         (t cl-tree)))
 626
 627 (defun cl-acons (key value alist)
 628   "Add KEY and VALUE to ALIST.
 629 Return a new list with (cons KEY VALUE) as car and ALIST as cdr."
 630   (cons (cons key value) alist))
 631
 632 (defun cl-pairlis (keys values &optional alist)
 633   "Make an alist from KEYS and VALUES.
 634 Return a new alist composed by associating KEYS to corresponding VALUES;
 635 the process stops as soon as KEYS or VALUES run out.
 636 If ALIST is non-nil, the new pairs are prepended to it."
 637   (nconc (cl-mapcar 'cons keys values) alist))
 638
 639
 640 ;;; Miscellaneous.
 641
 642 ;;;###autoload
 643 (progn
 644   ;; Autoload, so autoload.el and font-lock can use it even when CL
 645   ;; is not loaded.
 646   (put 'cl-defun    'doc-string-elt 3)
 647   (put 'cl-defmacro 'doc-string-elt 3)
 648   (put 'cl-defsubst 'doc-string-elt 3)
 649   (put 'cl-defstruct 'doc-string-elt 2))
 650
 651 (load "cl-loaddefs" nil 'quiet)
 652
 653 (provide 'cl-lib)
 654
 655 (run-hooks 'cl-load-hook)
 656
 657 ;; Local variables:
 658 ;; byte-compile-dynamic: t
 659 ;; byte-compile-warnings: (not cl-functions)
 660 ;; End:
 661
 662 ;;; cl-lib.el ends here