| 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: 1.0 |
| 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 | (require 'macroexp) |
| 95 | |
| 96 | (defvar cl-optimize-speed 1) |
| 97 | (defvar cl-optimize-safety 1) |
| 98 | |
| 99 | ;;;###autoload |
| 100 | (define-obsolete-variable-alias |
| 101 | ;; This alias is needed for compatibility with .elc files that use defstruct |
| 102 | ;; and were compiled with Emacs<24.3. |
| 103 | 'custom-print-functions 'cl-custom-print-functions "24.3") |
| 104 | |
| 105 | ;;;###autoload |
| 106 | (defvar cl-custom-print-functions nil |
| 107 | "This is a list of functions that format user objects for printing. |
| 108 | Each function is called in turn with three arguments: the object, the |
| 109 | stream, and the print level (currently ignored). If it is able to |
| 110 | print the object it returns true; otherwise it returns nil and the |
| 111 | printer proceeds to the next function on the list. |
| 112 | |
| 113 | This variable is not used at present, but it is defined in hopes that |
| 114 | a future Emacs interpreter will be able to use it.") |
| 115 | |
| 116 | (defun cl-unload-function () |
| 117 | "Stop unloading of the Common Lisp extensions." |
| 118 | (message "Cannot unload the feature `cl'") |
| 119 | ;; Stop standard unloading! |
| 120 | t) |
| 121 | |
| 122 | ;;; Generalized variables. |
| 123 | ;; These macros are defined here so that they |
| 124 | ;; can safely be used in init files. |
| 125 | |
| 126 | (defmacro cl-incf (place &optional x) |
| 127 | "Increment PLACE by X (1 by default). |
| 128 | PLACE may be a symbol, or any generalized variable allowed by `setf'. |
| 129 | The return value is the incremented value of PLACE." |
| 130 | (declare (debug (place &optional form))) |
| 131 | (if (symbolp place) |
| 132 | (list 'setq place (if x (list '+ place x) (list '1+ place))) |
| 133 | (list 'cl-callf '+ place (or x 1)))) |
| 134 | |
| 135 | (defmacro cl-decf (place &optional x) |
| 136 | "Decrement PLACE by X (1 by default). |
| 137 | PLACE may be a symbol, or any generalized variable allowed by `setf'. |
| 138 | The return value is the decremented value of PLACE." |
| 139 | (declare (debug cl-incf)) |
| 140 | (if (symbolp place) |
| 141 | (list 'setq place (if x (list '- place x) (list '1- place))) |
| 142 | (list 'cl-callf '- place (or x 1)))) |
| 143 | |
| 144 | (defmacro cl-pushnew (x place &rest keys) |
| 145 | "(cl-pushnew X PLACE): insert X at the head of the list if not already there. |
| 146 | Like (push X PLACE), except that the list is unmodified if X is `eql' to |
| 147 | an element already on the list. |
| 148 | \nKeywords supported: :test :test-not :key |
| 149 | \n(fn X PLACE [KEYWORD VALUE]...)" |
| 150 | (declare (debug |
| 151 | (form place &rest |
| 152 | &or [[&or ":test" ":test-not" ":key"] function-form] |
| 153 | [keywordp form]))) |
| 154 | (if (symbolp place) |
| 155 | (if (null keys) |
| 156 | (macroexp-let2 nil var x |
| 157 | `(if (memql ,var ,place) |
| 158 | ;; This symbol may later on expand to actual code which then |
| 159 | ;; trigger warnings like "value unused" since cl-pushnew's |
| 160 | ;; return value is rarely used. It should not matter that |
| 161 | ;; other warnings may be silenced, since `place' is used |
| 162 | ;; earlier and should have triggered them already. |
| 163 | (with-no-warnings ,place) |
| 164 | (setq ,place (cons ,var ,place)))) |
| 165 | (list 'setq place (cl-list* 'cl-adjoin x place keys))) |
| 166 | (cl-list* 'cl-callf2 'cl-adjoin x place keys))) |
| 167 | |
| 168 | (defun cl--set-elt (seq n val) |
| 169 | (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) |
| 170 | |
| 171 | (defun cl--set-buffer-substring (start end val) |
| 172 | (save-excursion (delete-region start end) |
| 173 | (goto-char start) |
| 174 | (insert val) |
| 175 | val)) |
| 176 | |
| 177 | (defun cl--set-substring (str start end val) |
| 178 | (if end (if (< end 0) (cl-incf end (length str))) |
| 179 | (setq end (length str))) |
| 180 | (if (< start 0) (cl-incf start (length str))) |
| 181 | (concat (and (> start 0) (substring str 0 start)) |
| 182 | val |
| 183 | (and (< end (length str)) (substring str end)))) |
| 184 | |
| 185 | |
| 186 | ;;; Blocks and exits. |
| 187 | |
| 188 | (defalias 'cl--block-wrapper 'identity) |
| 189 | (defalias 'cl--block-throw 'throw) |
| 190 | |
| 191 | |
| 192 | ;;; Multiple values. |
| 193 | ;; True multiple values are not supported, or even |
| 194 | ;; simulated. Instead, cl-multiple-value-bind and friends simply expect |
| 195 | ;; the target form to return the values as a list. |
| 196 | |
| 197 | (defun cl--defalias (cl-f el-f &optional doc) |
| 198 | (defalias cl-f el-f doc) |
| 199 | (put cl-f 'byte-optimizer 'byte-compile-inline-expand)) |
| 200 | |
| 201 | (cl--defalias 'cl-values #'list |
| 202 | "Return multiple values, Common Lisp style. |
| 203 | The arguments of `cl-values' are the values |
| 204 | that the containing function should return. |
| 205 | |
| 206 | \(fn &rest VALUES)") |
| 207 | |
| 208 | (cl--defalias 'cl-values-list #'identity |
| 209 | "Return multiple values, Common Lisp style, taken from a list. |
| 210 | LIST specifies the list of values |
| 211 | that the containing function should return. |
| 212 | |
| 213 | \(fn LIST)") |
| 214 | |
| 215 | (defsubst cl-multiple-value-list (expression) |
| 216 | "Return a list of the multiple values produced by EXPRESSION. |
| 217 | This handles multiple values in Common Lisp style, but it does not |
| 218 | work right when EXPRESSION calls an ordinary Emacs Lisp function |
| 219 | that returns just one value." |
| 220 | expression) |
| 221 | |
| 222 | (defsubst cl-multiple-value-apply (function expression) |
| 223 | "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. |
| 224 | This handles multiple values in Common Lisp style, but it does not work |
| 225 | right when EXPRESSION calls an ordinary Emacs Lisp function that returns just |
| 226 | one value." |
| 227 | (apply function expression)) |
| 228 | |
| 229 | (defalias 'cl-multiple-value-call 'apply |
| 230 | "Apply FUNCTION to ARGUMENTS, taking multiple values into account. |
| 231 | This implementation only handles the case where there is only one argument.") |
| 232 | |
| 233 | (cl--defalias 'cl-nth-value #'nth |
| 234 | "Evaluate EXPRESSION to get multiple values and return the Nth one. |
| 235 | This handles multiple values in Common Lisp style, but it does not work |
| 236 | right when EXPRESSION calls an ordinary Emacs Lisp function that returns just |
| 237 | one value. |
| 238 | |
| 239 | \(fn N EXPRESSION)") |
| 240 | |
| 241 | ;;; Declarations. |
| 242 | |
| 243 | (defvar cl--compiling-file nil) |
| 244 | (defun cl--compiling-file () |
| 245 | (or cl--compiling-file |
| 246 | (and (boundp 'byte-compile--outbuffer) |
| 247 | (bufferp (symbol-value 'byte-compile--outbuffer)) |
| 248 | (equal (buffer-name (symbol-value 'byte-compile--outbuffer)) |
| 249 | " *Compiler Output*")))) |
| 250 | |
| 251 | (defvar cl-proclaims-deferred nil) |
| 252 | |
| 253 | (defun cl-proclaim (spec) |
| 254 | "Record a global declaration specified by SPEC." |
| 255 | (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t) |
| 256 | (push spec cl-proclaims-deferred)) |
| 257 | nil) |
| 258 | |
| 259 | (defmacro cl-declaim (&rest specs) |
| 260 | "Like `cl-proclaim', but takes any number of unevaluated, unquoted arguments. |
| 261 | Puts `(cl-eval-when (compile load eval) ...)' around the declarations |
| 262 | so that they are registered at compile-time as well as run-time." |
| 263 | (let ((body (mapcar (function (lambda (x) |
| 264 | (list 'cl-proclaim (list 'quote x)))) |
| 265 | specs))) |
| 266 | (if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body) |
| 267 | (cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when |
| 268 | |
| 269 | |
| 270 | ;;; Symbols. |
| 271 | |
| 272 | (defun cl--random-time () |
| 273 | (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) |
| 274 | (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) |
| 275 | v)) |
| 276 | |
| 277 | (defvar cl--gensym-counter (* (logand (cl--random-time) 1023) 100)) |
| 278 | |
| 279 | |
| 280 | ;;; Numbers. |
| 281 | |
| 282 | (defun cl-floatp-safe (object) |
| 283 | "Return t if OBJECT is a floating point number. |
| 284 | On Emacs versions that lack floating-point support, this function |
| 285 | always returns nil." |
| 286 | (and (numberp object) (not (integerp object)))) |
| 287 | |
| 288 | (defsubst cl-plusp (number) |
| 289 | "Return t if NUMBER is positive." |
| 290 | (> number 0)) |
| 291 | |
| 292 | (defsubst cl-minusp (number) |
| 293 | "Return t if NUMBER is negative." |
| 294 | (< number 0)) |
| 295 | |
| 296 | (defun cl-oddp (integer) |
| 297 | "Return t if INTEGER is odd." |
| 298 | (eq (logand integer 1) 1)) |
| 299 | |
| 300 | (defun cl-evenp (integer) |
| 301 | "Return t if INTEGER is even." |
| 302 | (eq (logand integer 1) 0)) |
| 303 | |
| 304 | (defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl--random-time))) |
| 305 | |
| 306 | (defconst cl-most-positive-float nil |
| 307 | "The largest value that a Lisp float can hold. |
| 308 | If your system supports infinities, this is the largest finite value. |
| 309 | For IEEE machines, this is approximately 1.79e+308. |
| 310 | Call `cl-float-limits' to set this.") |
| 311 | |
| 312 | (defconst cl-most-negative-float nil |
| 313 | "The largest negative value that a Lisp float can hold. |
| 314 | This is simply -`cl-most-positive-float'. |
| 315 | Call `cl-float-limits' to set this.") |
| 316 | |
| 317 | (defconst cl-least-positive-float nil |
| 318 | "The smallest value greater than zero that a Lisp float can hold. |
| 319 | For IEEE machines, it is about 4.94e-324 if denormals are supported, |
| 320 | or 2.22e-308 if they are not. |
| 321 | Call `cl-float-limits' to set this.") |
| 322 | |
| 323 | (defconst cl-least-negative-float nil |
| 324 | "The smallest value less than zero that a Lisp float can hold. |
| 325 | This is simply -`cl-least-positive-float'. |
| 326 | Call `cl-float-limits' to set this.") |
| 327 | |
| 328 | (defconst cl-least-positive-normalized-float nil |
| 329 | "The smallest normalized Lisp float greater than zero. |
| 330 | This is the smallest value for which IEEE denormalization does not lose |
| 331 | precision. For IEEE machines, this value is about 2.22e-308. |
| 332 | For machines that do not support the concept of denormalization |
| 333 | and gradual underflow, this constant equals `cl-least-positive-float'. |
| 334 | Call `cl-float-limits' to set this.") |
| 335 | |
| 336 | (defconst cl-least-negative-normalized-float nil |
| 337 | "The smallest normalized Lisp float less than zero. |
| 338 | This is simply -`cl-least-positive-normalized-float'. |
| 339 | Call `cl-float-limits' to set this.") |
| 340 | |
| 341 | (defconst cl-float-epsilon nil |
| 342 | "The smallest positive float that adds to 1.0 to give a distinct value. |
| 343 | Adding a number less than this to 1.0 returns 1.0 due to roundoff. |
| 344 | For IEEE machines, epsilon is about 2.22e-16. |
| 345 | Call `cl-float-limits' to set this.") |
| 346 | |
| 347 | (defconst cl-float-negative-epsilon nil |
| 348 | "The smallest positive float that subtracts from 1.0 to give a distinct value. |
| 349 | For IEEE machines, it is about 1.11e-16. |
| 350 | Call `cl-float-limits' to set this.") |
| 351 | |
| 352 | |
| 353 | ;;; Sequence functions. |
| 354 | |
| 355 | (cl--defalias 'cl-copy-seq 'copy-sequence) |
| 356 | |
| 357 | (declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs)) |
| 358 | |
| 359 | (defun cl-mapcar (cl-func cl-x &rest cl-rest) |
| 360 | "Apply FUNCTION to each element of SEQ, and make a list of the results. |
| 361 | If there are several SEQs, FUNCTION is called with that many arguments, |
| 362 | and mapping stops as soon as the shortest list runs out. With just one |
| 363 | SEQ, this is like `mapcar'. With several, it is like the Common Lisp |
| 364 | `mapcar' function extended to arbitrary sequence types. |
| 365 | \n(fn FUNCTION SEQ...)" |
| 366 | (if cl-rest |
| 367 | (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) |
| 368 | (cl--mapcar-many cl-func (cons cl-x cl-rest)) |
| 369 | (let ((cl-res nil) (cl-y (car cl-rest))) |
| 370 | (while (and cl-x cl-y) |
| 371 | (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) |
| 372 | (nreverse cl-res))) |
| 373 | (mapcar cl-func cl-x))) |
| 374 | |
| 375 | (cl--defalias 'cl-svref 'aref) |
| 376 | |
| 377 | ;;; List functions. |
| 378 | |
| 379 | (cl--defalias 'cl-first 'car) |
| 380 | (cl--defalias 'cl-second 'cadr) |
| 381 | (cl--defalias 'cl-rest 'cdr) |
| 382 | (cl--defalias 'cl-endp 'null) |
| 383 | |
| 384 | (cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.") |
| 385 | (cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.") |
| 386 | |
| 387 | (defsubst cl-fifth (x) |
| 388 | "Return the fifth element of the list X." |
| 389 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 4 ,x) ,store)))) |
| 390 | (nth 4 x)) |
| 391 | |
| 392 | (defsubst cl-sixth (x) |
| 393 | "Return the sixth element of the list X." |
| 394 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 5 ,x) ,store)))) |
| 395 | (nth 5 x)) |
| 396 | |
| 397 | (defsubst cl-seventh (x) |
| 398 | "Return the seventh element of the list X." |
| 399 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 6 ,x) ,store)))) |
| 400 | (nth 6 x)) |
| 401 | |
| 402 | (defsubst cl-eighth (x) |
| 403 | "Return the eighth element of the list X." |
| 404 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 7 ,x) ,store)))) |
| 405 | (nth 7 x)) |
| 406 | |
| 407 | (defsubst cl-ninth (x) |
| 408 | "Return the ninth element of the list X." |
| 409 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 8 ,x) ,store)))) |
| 410 | (nth 8 x)) |
| 411 | |
| 412 | (defsubst cl-tenth (x) |
| 413 | "Return the tenth element of the list X." |
| 414 | (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store)))) |
| 415 | (nth 9 x)) |
| 416 | |
| 417 | (defun cl-caaar (x) |
| 418 | "Return the `car' of the `car' of the `car' of X." |
| 419 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 420 | (car (car (car x)))) |
| 421 | |
| 422 | (defun cl-caadr (x) |
| 423 | "Return the `car' of the `car' of the `cdr' of X." |
| 424 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 425 | (car (car (cdr x)))) |
| 426 | |
| 427 | (defun cl-cadar (x) |
| 428 | "Return the `car' of the `cdr' of the `car' of X." |
| 429 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 430 | (car (cdr (car x)))) |
| 431 | |
| 432 | (defun cl-caddr (x) |
| 433 | "Return the `car' of the `cdr' of the `cdr' of X." |
| 434 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 435 | (car (cdr (cdr x)))) |
| 436 | |
| 437 | (defun cl-cdaar (x) |
| 438 | "Return the `cdr' of the `car' of the `car' of X." |
| 439 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 440 | (cdr (car (car x)))) |
| 441 | |
| 442 | (defun cl-cdadr (x) |
| 443 | "Return the `cdr' of the `car' of the `cdr' of X." |
| 444 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 445 | (cdr (car (cdr x)))) |
| 446 | |
| 447 | (defun cl-cddar (x) |
| 448 | "Return the `cdr' of the `cdr' of the `car' of X." |
| 449 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 450 | (cdr (cdr (car x)))) |
| 451 | |
| 452 | (defun cl-cdddr (x) |
| 453 | "Return the `cdr' of the `cdr' of the `cdr' of X." |
| 454 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 455 | (cdr (cdr (cdr x)))) |
| 456 | |
| 457 | (defun cl-caaaar (x) |
| 458 | "Return the `car' of the `car' of the `car' of the `car' of X." |
| 459 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 460 | (car (car (car (car x))))) |
| 461 | |
| 462 | (defun cl-caaadr (x) |
| 463 | "Return the `car' of the `car' of the `car' of the `cdr' of X." |
| 464 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 465 | (car (car (car (cdr x))))) |
| 466 | |
| 467 | (defun cl-caadar (x) |
| 468 | "Return the `car' of the `car' of the `cdr' of the `car' of X." |
| 469 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 470 | (car (car (cdr (car x))))) |
| 471 | |
| 472 | (defun cl-caaddr (x) |
| 473 | "Return the `car' of the `car' of the `cdr' of the `cdr' of X." |
| 474 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 475 | (car (car (cdr (cdr x))))) |
| 476 | |
| 477 | (defun cl-cadaar (x) |
| 478 | "Return the `car' of the `cdr' of the `car' of the `car' of X." |
| 479 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 480 | (car (cdr (car (car x))))) |
| 481 | |
| 482 | (defun cl-cadadr (x) |
| 483 | "Return the `car' of the `cdr' of the `car' of the `cdr' of X." |
| 484 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 485 | (car (cdr (car (cdr x))))) |
| 486 | |
| 487 | (defun cl-caddar (x) |
| 488 | "Return the `car' of the `cdr' of the `cdr' of the `car' of X." |
| 489 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 490 | (car (cdr (cdr (car x))))) |
| 491 | |
| 492 | (defun cl-cadddr (x) |
| 493 | "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." |
| 494 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 495 | (car (cdr (cdr (cdr x))))) |
| 496 | |
| 497 | (defun cl-cdaaar (x) |
| 498 | "Return the `cdr' of the `car' of the `car' of the `car' of X." |
| 499 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 500 | (cdr (car (car (car x))))) |
| 501 | |
| 502 | (defun cl-cdaadr (x) |
| 503 | "Return the `cdr' of the `car' of the `car' of the `cdr' of X." |
| 504 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 505 | (cdr (car (car (cdr x))))) |
| 506 | |
| 507 | (defun cl-cdadar (x) |
| 508 | "Return the `cdr' of the `car' of the `cdr' of the `car' of X." |
| 509 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 510 | (cdr (car (cdr (car x))))) |
| 511 | |
| 512 | (defun cl-cdaddr (x) |
| 513 | "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." |
| 514 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 515 | (cdr (car (cdr (cdr x))))) |
| 516 | |
| 517 | (defun cl-cddaar (x) |
| 518 | "Return the `cdr' of the `cdr' of the `car' of the `car' of X." |
| 519 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 520 | (cdr (cdr (car (car x))))) |
| 521 | |
| 522 | (defun cl-cddadr (x) |
| 523 | "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." |
| 524 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 525 | (cdr (cdr (car (cdr x))))) |
| 526 | |
| 527 | (defun cl-cdddar (x) |
| 528 | "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." |
| 529 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 530 | (cdr (cdr (cdr (car x))))) |
| 531 | |
| 532 | (defun cl-cddddr (x) |
| 533 | "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." |
| 534 | (declare (compiler-macro cl--compiler-macro-cXXr)) |
| 535 | (cdr (cdr (cdr (cdr x))))) |
| 536 | |
| 537 | ;;(defun last* (x &optional n) |
| 538 | ;; "Returns the last link in the list LIST. |
| 539 | ;;With optional argument N, returns Nth-to-last link (default 1)." |
| 540 | ;; (if n |
| 541 | ;; (let ((m 0) (p x)) |
| 542 | ;; (while (consp p) (cl-incf m) (pop p)) |
| 543 | ;; (if (<= n 0) p |
| 544 | ;; (if (< n m) (nthcdr (- m n) x) x))) |
| 545 | ;; (while (consp (cdr x)) (pop x)) |
| 546 | ;; x)) |
| 547 | |
| 548 | (defun cl-list* (arg &rest rest) |
| 549 | "Return a new list with specified ARGs as elements, consed to last ARG. |
| 550 | Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to |
| 551 | `(cons A (cons B (cons C D)))'. |
| 552 | \n(fn ARG...)" |
| 553 | (declare (compiler-macro cl--compiler-macro-list*)) |
| 554 | (cond ((not rest) arg) |
| 555 | ((not (cdr rest)) (cons arg (car rest))) |
| 556 | (t (let* ((n (length rest)) |
| 557 | (copy (copy-sequence rest)) |
| 558 | (last (nthcdr (- n 2) copy))) |
| 559 | (setcdr last (car (cdr last))) |
| 560 | (cons arg copy))))) |
| 561 | |
| 562 | (defun cl-ldiff (list sublist) |
| 563 | "Return a copy of LIST with the tail SUBLIST removed." |
| 564 | (let ((res nil)) |
| 565 | (while (and (consp list) (not (eq list sublist))) |
| 566 | (push (pop list) res)) |
| 567 | (nreverse res))) |
| 568 | |
| 569 | (defun cl-copy-list (list) |
| 570 | "Return a copy of LIST, which may be a dotted list. |
| 571 | The elements of LIST are not copied, just the list structure itself." |
| 572 | (if (consp list) |
| 573 | (let ((res nil)) |
| 574 | (while (consp list) (push (pop list) res)) |
| 575 | (prog1 (nreverse res) (setcdr res list))) |
| 576 | (car list))) |
| 577 | |
| 578 | ;; Autoloaded, but we have not loaded cl-loaddefs yet. |
| 579 | (declare-function cl-floor "cl-extra" (x &optional y)) |
| 580 | (declare-function cl-ceiling "cl-extra" (x &optional y)) |
| 581 | (declare-function cl-truncate "cl-extra" (x &optional y)) |
| 582 | (declare-function cl-round "cl-extra" (x &optional y)) |
| 583 | (declare-function cl-mod "cl-extra" (x y)) |
| 584 | |
| 585 | (defun cl-adjoin (cl-item cl-list &rest cl-keys) |
| 586 | "Return ITEM consed onto the front of LIST only if it's not already there. |
| 587 | Otherwise, return LIST unmodified. |
| 588 | \nKeywords supported: :test :test-not :key |
| 589 | \n(fn ITEM LIST [KEYWORD VALUE]...)" |
| 590 | (declare (compiler-macro cl--compiler-macro-adjoin)) |
| 591 | (cond ((or (equal cl-keys '(:test eq)) |
| 592 | (and (null cl-keys) (not (numberp cl-item)))) |
| 593 | (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) |
| 594 | ((or (equal cl-keys '(:test equal)) (null cl-keys)) |
| 595 | (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) |
| 596 | (t (apply 'cl--adjoin cl-item cl-list cl-keys)))) |
| 597 | |
| 598 | (defun cl-subst (cl-new cl-old cl-tree &rest cl-keys) |
| 599 | "Substitute NEW for OLD everywhere in TREE (non-destructively). |
| 600 | Return a copy of TREE with all elements `eql' to OLD replaced by NEW. |
| 601 | \nKeywords supported: :test :test-not :key |
| 602 | \n(fn NEW OLD TREE [KEYWORD VALUE]...)" |
| 603 | (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) |
| 604 | (apply 'cl-sublis (list (cons cl-old cl-new)) cl-tree cl-keys) |
| 605 | (cl--do-subst cl-new cl-old cl-tree))) |
| 606 | |
| 607 | (defun cl--do-subst (cl-new cl-old cl-tree) |
| 608 | (cond ((eq cl-tree cl-old) cl-new) |
| 609 | ((consp cl-tree) |
| 610 | (let ((a (cl--do-subst cl-new cl-old (car cl-tree))) |
| 611 | (d (cl--do-subst cl-new cl-old (cdr cl-tree)))) |
| 612 | (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) |
| 613 | cl-tree (cons a d)))) |
| 614 | (t cl-tree))) |
| 615 | |
| 616 | (defun cl-acons (key value alist) |
| 617 | "Add KEY and VALUE to ALIST. |
| 618 | Return a new list with (cons KEY VALUE) as car and ALIST as cdr." |
| 619 | (cons (cons key value) alist)) |
| 620 | |
| 621 | (defun cl-pairlis (keys values &optional alist) |
| 622 | "Make an alist from KEYS and VALUES. |
| 623 | Return a new alist composed by associating KEYS to corresponding VALUES; |
| 624 | the process stops as soon as KEYS or VALUES run out. |
| 625 | If ALIST is non-nil, the new pairs are prepended to it." |
| 626 | (nconc (cl-mapcar 'cons keys values) alist)) |
| 627 | |
| 628 | |
| 629 | ;;; Generalized variables. |
| 630 | |
| 631 | ;; These used to be in cl-macs.el since all macros that use them (like setf) |
| 632 | ;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in |
| 633 | ;; core Elisp, they need to either be right here or be autoloaded via |
| 634 | ;; cl-loaddefs.el, which is more trouble than it is worth. |
| 635 | |
| 636 | ;; Some more Emacs-related place types. |
| 637 | (gv-define-simple-setter buffer-file-name set-visited-file-name t) |
| 638 | (gv-define-setter buffer-modified-p (flag &optional buf) |
| 639 | `(with-current-buffer ,buf |
| 640 | (set-buffer-modified-p ,flag))) |
| 641 | (gv-define-simple-setter buffer-name rename-buffer t) |
| 642 | (gv-define-setter buffer-string (store) |
| 643 | `(insert (prog1 ,store (erase-buffer)))) |
| 644 | (gv-define-simple-setter buffer-substring cl--set-buffer-substring) |
| 645 | (gv-define-simple-setter current-buffer set-buffer) |
| 646 | (gv-define-simple-setter current-case-table set-case-table) |
| 647 | (gv-define-simple-setter current-column move-to-column t) |
| 648 | (gv-define-simple-setter current-global-map use-global-map t) |
| 649 | (gv-define-setter current-input-mode (store) |
| 650 | `(progn (apply #'set-input-mode ,store) ,store)) |
| 651 | (gv-define-simple-setter current-local-map use-local-map t) |
| 652 | (gv-define-simple-setter current-window-configuration |
| 653 | set-window-configuration t) |
| 654 | (gv-define-simple-setter default-file-modes set-default-file-modes t) |
| 655 | (gv-define-simple-setter documentation-property put) |
| 656 | (gv-define-setter face-background (x f &optional s) |
| 657 | `(set-face-background ,f ,x ,s)) |
| 658 | (gv-define-setter face-background-pixmap (x f &optional s) |
| 659 | `(set-face-background-pixmap ,f ,x ,s)) |
| 660 | (gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s)) |
| 661 | (gv-define-setter face-foreground (x f &optional s) |
| 662 | `(set-face-foreground ,f ,x ,s)) |
| 663 | (gv-define-setter face-underline-p (x f &optional s) |
| 664 | `(set-face-underline ,f ,x ,s)) |
| 665 | (gv-define-simple-setter file-modes set-file-modes t) |
| 666 | (gv-define-simple-setter frame-height set-screen-height t) |
| 667 | (gv-define-simple-setter frame-parameters modify-frame-parameters t) |
| 668 | (gv-define-simple-setter frame-visible-p cl--set-frame-visible-p) |
| 669 | (gv-define-simple-setter frame-width set-screen-width t) |
| 670 | (gv-define-simple-setter getenv setenv t) |
| 671 | (gv-define-simple-setter get-register set-register) |
| 672 | (gv-define-simple-setter global-key-binding global-set-key) |
| 673 | (gv-define-simple-setter local-key-binding local-set-key) |
| 674 | (gv-define-simple-setter mark set-mark t) |
| 675 | (gv-define-simple-setter mark-marker set-mark t) |
| 676 | (gv-define-simple-setter marker-position set-marker t) |
| 677 | (gv-define-setter mouse-position (store scr) |
| 678 | `(set-mouse-position ,scr (car ,store) (cadr ,store) |
| 679 | (cddr ,store))) |
| 680 | (gv-define-simple-setter point goto-char) |
| 681 | (gv-define-simple-setter point-marker goto-char t) |
| 682 | (gv-define-setter point-max (store) |
| 683 | `(progn (narrow-to-region (point-min) ,store) ,store)) |
| 684 | (gv-define-setter point-min (store) |
| 685 | `(progn (narrow-to-region ,store (point-max)) ,store)) |
| 686 | (gv-define-setter read-mouse-position (store scr) |
| 687 | `(set-mouse-position ,scr (car ,store) (cdr ,store))) |
| 688 | (gv-define-simple-setter screen-height set-screen-height t) |
| 689 | (gv-define-simple-setter screen-width set-screen-width t) |
| 690 | (gv-define-simple-setter selected-window select-window) |
| 691 | (gv-define-simple-setter selected-screen select-screen) |
| 692 | (gv-define-simple-setter selected-frame select-frame) |
| 693 | (gv-define-simple-setter standard-case-table set-standard-case-table) |
| 694 | (gv-define-simple-setter syntax-table set-syntax-table) |
| 695 | (gv-define-simple-setter visited-file-modtime set-visited-file-modtime t) |
| 696 | (gv-define-setter window-height (store) |
| 697 | `(progn (enlarge-window (- ,store (window-height))) ,store)) |
| 698 | (gv-define-setter window-width (store) |
| 699 | `(progn (enlarge-window (- ,store (window-width)) t) ,store)) |
| 700 | (gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t) |
| 701 | (gv-define-simple-setter x-get-selection x-own-selection t) |
| 702 | |
| 703 | ;; More complex setf-methods. |
| 704 | |
| 705 | ;; This is a hack that allows (setf (eq a 7) B) to mean either |
| 706 | ;; (setq a 7) or (setq a nil) depending on whether B is nil or not. |
| 707 | ;; This is useful when you have control over the PLACE but not over |
| 708 | ;; the VALUE, as is the case in define-minor-mode's :variable. |
| 709 | ;; It turned out that :variable needed more flexibility anyway, so |
| 710 | ;; this doesn't seem too useful now. |
| 711 | (gv-define-expander eq |
| 712 | (lambda (do place val) |
| 713 | (gv-letplace (getter setter) place |
| 714 | (macroexp-let2 nil val val |
| 715 | (funcall do `(eq ,getter ,val) |
| 716 | (lambda (v) |
| 717 | `(cond |
| 718 | (,v ,(funcall setter val)) |
| 719 | ((eq ,getter ,val) ,(funcall setter `(not ,val)))))))))) |
| 720 | |
| 721 | (gv-define-expander substring |
| 722 | (lambda (do place from &optional to) |
| 723 | (gv-letplace (getter setter) place |
| 724 | (macroexp-let2 nil start from |
| 725 | (macroexp-let2 nil end to |
| 726 | (funcall do `(substring ,getter ,start ,end) |
| 727 | (lambda (v) |
| 728 | (funcall setter `(cl--set-substring |
| 729 | ,getter ,start ,end ,v))))))))) |
| 730 | |
| 731 | ;;; Miscellaneous. |
| 732 | |
| 733 | ;;;###autoload |
| 734 | (progn |
| 735 | ;; Make sure functions defined with cl-defsubst can be inlined even in |
| 736 | ;; packages which do not require CL. We don't put an autoload cookie |
| 737 | ;; directly on that function, since those cookies only go to cl-loaddefs. |
| 738 | (autoload 'cl--defsubst-expand "cl-macs") |
| 739 | ;; Autoload, so autoload.el and font-lock can use it even when CL |
| 740 | ;; is not loaded. |
| 741 | (put 'cl-defun 'doc-string-elt 3) |
| 742 | (put 'cl-defmacro 'doc-string-elt 3) |
| 743 | (put 'cl-defsubst 'doc-string-elt 3) |
| 744 | (put 'cl-defstruct 'doc-string-elt 2)) |
| 745 | |
| 746 | (load "cl-loaddefs" nil 'quiet) |
| 747 | |
| 748 | (provide 'cl-lib) |
| 749 | |
| 750 | (run-hooks 'cl-load-hook) |
| 751 | |
| 752 | ;; Local variables: |
| 753 | ;; byte-compile-dynamic: t |
| 754 | ;; End: |
| 755 | |
| 756 | ;;; cl-lib.el ends here |