613
+ − 1 ;;; cl.el --- Common Lisp extensions for XEmacs Lisp
428
+ − 2
+ − 3 ;; Copyright (C) 1993, 1997 Free Software Foundation, Inc.
+ − 4
+ − 5 ;; Author: Dave Gillespie <daveg@synaptics.com>
+ − 6 ;; Maintainer: XEmacs Development Team
+ − 7 ;; Version: 2.02
+ − 8 ;; Keywords: extensions, dumped, lisp
+ − 9
+ − 10 ;; This file is part of XEmacs.
+ − 11
+ − 12 ;; XEmacs is free software; you can redistribute it and/or modify it
+ − 13 ;; under the terms of the GNU General Public License as published by
+ − 14 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 15 ;; any later version.
+ − 16
+ − 17 ;; XEmacs is distributed in the hope that it will be useful, but
+ − 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ − 20 ;; General Public License for more details.
+ − 21
+ − 22 ;; You should have received a copy of the GNU General Public License
+ − 23 ;; along with XEmacs; see the file COPYING. If not, write to the Free
+ − 24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ − 25 ;; 02111-1307, USA.
+ − 26
+ − 27 ;;; Synched up with: FSF 19.34.
+ − 28
+ − 29 ;;; Commentary:
+ − 30
+ − 31 ;; This file is dumped with XEmacs.
+ − 32
+ − 33 ;; These are extensions to Emacs Lisp that provide a degree of
+ − 34 ;; Common Lisp compatibility, beyond what is already built-in
+ − 35 ;; in Emacs Lisp.
+ − 36 ;;
+ − 37 ;; This package was written by Dave Gillespie; it is a complete
+ − 38 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
+ − 39 ;;
+ − 40 ;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19.
+ − 41 ;;
+ − 42 ;; Bug reports, comments, and suggestions are welcome!
+ − 43
+ − 44 ;; This file contains the portions of the Common Lisp extensions
+ − 45 ;; package which should always be present.
+ − 46
+ − 47
+ − 48 ;;; Future notes:
+ − 49
+ − 50 ;; Once Emacs 19 becomes standard, many things in this package which are
+ − 51 ;; messy for reasons of compatibility can be greatly simplified. For now,
+ − 52 ;; I prefer to maintain one unified version.
+ − 53
+ − 54
+ − 55 ;;; Change Log:
+ − 56
+ − 57 ;; Version 2.02 (30 Jul 93):
+ − 58 ;; * Added "cl-compat.el" file, extra compatibility with old package.
+ − 59 ;; * Added `lexical-let' and `lexical-let*'.
+ − 60 ;; * Added `define-modify-macro', `callf', and `callf2'.
+ − 61 ;; * Added `ignore-errors'.
+ − 62 ;; * Changed `(setf (nthcdr N PLACE) X)' to work when N is zero.
+ − 63 ;; * Merged `*gentemp-counter*' into `*gensym-counter*'.
+ − 64 ;; * Extended `subseq' to allow negative START and END like `substring'.
+ − 65 ;; * Added `in-ref', `across-ref', `elements of-ref' loop clauses.
+ − 66 ;; * Added `concat', `vconcat' loop clauses.
+ − 67 ;; * Cleaned up a number of compiler warnings.
+ − 68
+ − 69 ;; Version 2.01 (7 Jul 93):
+ − 70 ;; * Added support for FSF version of Emacs 19.
+ − 71 ;; * Added `add-hook' for Emacs 18 users.
+ − 72 ;; * Added `defsubst*' and `symbol-macrolet'.
+ − 73 ;; * Added `maplist', `mapc', `mapl', `mapcan', `mapcon'.
+ − 74 ;; * Added `map', `concatenate', `reduce', `merge'.
+ − 75 ;; * Added `revappend', `nreconc', `tailp', `tree-equal'.
+ − 76 ;; * Added `assert', `check-type', `typecase', `typep', and `deftype'.
+ − 77 ;; * Added destructuring and `&environment' support to `defmacro*'.
+ − 78 ;; * Added destructuring to `loop', and added the following clauses:
+ − 79 ;; `elements', `frames', `overlays', `intervals', `buffers', `key-seqs'.
+ − 80 ;; * Renamed `delete' to `delete*' and `remove' to `remove*'.
+ − 81 ;; * Completed support for all keywords in `remove*', `substitute', etc.
+ − 82 ;; * Added `most-positive-float' and company.
+ − 83 ;; * Fixed hash tables to work with latest Lucid Emacs.
+ − 84 ;; * `proclaim' forms are no longer compile-time-evaluating; use `declaim'.
+ − 85 ;; * Syntax for `warn' declarations has changed.
+ − 86 ;; * Improved implementation of `random*'.
+ − 87 ;; * Moved most sequence functions to a new file, cl-seq.el.
+ − 88 ;; * Moved `eval-when' into cl-macs.el.
+ − 89 ;; * Moved `pushnew' and `adjoin' to cl.el for most common cases.
+ − 90 ;; * Moved `provide' forms down to ends of files.
+ − 91 ;; * Changed expansion of `pop' to something that compiles to better code.
+ − 92 ;; * Changed so that no patch is required for Emacs 19 byte compiler.
+ − 93 ;; * Made more things dependent on `optimize' declarations.
+ − 94 ;; * Added a partial implementation of struct print functions.
+ − 95 ;; * Miscellaneous minor changes.
+ − 96
+ − 97 ;; Version 2.00:
+ − 98 ;; * First public release of this package.
+ − 99
+ − 100
+ − 101 ;;; Code:
+ − 102
+ − 103 (defvar cl-emacs-type (cond ((or (and (fboundp 'epoch::version)
+ − 104 (symbol-value 'epoch::version))
+ − 105 (string-lessp emacs-version "19")) 18)
+ − 106 ((string-match "XEmacs" emacs-version)
+ − 107 'lucid)
+ − 108 (t 19)))
+ − 109
+ − 110 (or (fboundp 'defalias) (fset 'defalias 'fset))
+ − 111
+ − 112 (defvar cl-optimize-speed 1)
+ − 113 (defvar cl-optimize-safety 1)
+ − 114
+ − 115
+ − 116 ;;; Keywords used in this package.
+ − 117
+ − 118 ;;; XEmacs - keywords are done in Fintern().
+ − 119 ;;;
+ − 120 ;;; (defconst :test ':test)
+ − 121 ;;; (defconst :test-not ':test-not)
+ − 122 ;;; (defconst :key ':key)
+ − 123 ;;; (defconst :start ':start)
+ − 124 ;;; (defconst :start1 ':start1)
+ − 125 ;;; (defconst :start2 ':start2)
+ − 126 ;;; (defconst :end ':end)
+ − 127 ;;; (defconst :end1 ':end1)
+ − 128 ;;; (defconst :end2 ':end2)
+ − 129 ;;; (defconst :count ':count)
+ − 130 ;;; (defconst :initial-value ':initial-value)
+ − 131 ;;; (defconst :size ':size)
+ − 132 ;;; (defconst :from-end ':from-end)
+ − 133 ;;; (defconst :rehash-size ':rehash-size)
+ − 134 ;;; (defconst :rehash-threshold ':rehash-threshold)
+ − 135 ;;; (defconst :allow-other-keys ':allow-other-keys)
+ − 136
+ − 137
+ − 138 (defvar custom-print-functions nil
+ − 139 "This is a list of functions that format user objects for printing.
+ − 140 Each function is called in turn with three arguments: the object, the
+ − 141 stream, and the print level (currently ignored). If it is able to
+ − 142 print the object it returns true; otherwise it returns nil and the
+ − 143 printer proceeds to the next function on the list.
+ − 144
+ − 145 This variable is not used at present, but it is defined in hopes that
+ − 146 a future Emacs interpreter will be able to use it.")
+ − 147
+ − 148
+ − 149 ;;; Predicates.
+ − 150
+ − 151 (defun eql (a b) ; See compiler macro in cl-macs.el
+ − 152 "Return t if the two args are the same Lisp object.
+ − 153 Floating-point numbers of equal value are `eql', but they may not be `eq'."
+ − 154 (if (floatp a)
+ − 155 (equal a b)
+ − 156 (eq a b)))
+ − 157
+ − 158
+ − 159 ;;; Generalized variables. These macros are defined here so that they
+ − 160 ;;; can safely be used in .emacs files.
+ − 161
+ − 162 (defmacro incf (place &optional x)
+ − 163 "(incf PLACE [X]): increment PLACE by X (1 by default).
+ − 164 PLACE may be a symbol, or any generalized variable allowed by `setf'.
+ − 165 The return value is the incremented value of PLACE."
+ − 166 (if (symbolp place)
+ − 167 (list 'setq place (if x (list '+ place x) (list '1+ place)))
+ − 168 ;; XEmacs byte-compiler optimizes (+ FOO 1) to (1+ FOO), so this
+ − 169 ;; is OK.
+ − 170 (list 'callf '+ place (or x 1))))
+ − 171
+ − 172 (defmacro decf (place &optional x)
+ − 173 "(decf PLACE [X]): decrement PLACE by X (1 by default).
+ − 174 PLACE may be a symbol, or any generalized variable allowed by `setf'.
+ − 175 The return value is the decremented value of PLACE."
+ − 176 (if (symbolp place)
+ − 177 (list 'setq place (if x (list '- place x) (list '1- place)))
+ − 178 (list 'callf '- place (or x 1))))
+ − 179
+ − 180 (defmacro pop (place)
+ − 181 "(pop PLACE): remove and return the head of the list stored in PLACE.
+ − 182 Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more
+ − 183 careful about evaluating each argument only once and in the right order.
+ − 184 PLACE may be a symbol, or any generalized variable allowed by `setf'."
+ − 185 (if (symbolp place)
+ − 186 `(car (prog1 ,place (setq ,place (cdr ,place))))
+ − 187 (cl-do-pop place)))
+ − 188
+ − 189 (defmacro push (x place)
+ − 190 "(push X PLACE): insert X at the head of the list stored in PLACE.
+ − 191 Analogous to (setf PLACE (cons X PLACE)), though more careful about
+ − 192 evaluating each argument only once and in the right order. PLACE may
+ − 193 be a symbol, or any generalized variable allowed by `setf'."
+ − 194 (if (symbolp place) `(setq ,place (cons ,x ,place))
+ − 195 (list 'callf2 'cons x place)))
+ − 196
+ − 197 (defmacro pushnew (x place &rest keys)
+ − 198 "(pushnew X PLACE): insert X at the head of the list if not already there.
+ − 199 Like (push X PLACE), except that the list is unmodified if X is `eql' to
+ − 200 an element already on the list.
+ − 201 Keywords supported: :test :test-not :key"
+ − 202 (if (symbolp place) (list 'setq place (list* 'adjoin x place keys))
+ − 203 (list* 'callf2 'adjoin x place keys)))
+ − 204
+ − 205 (defun cl-set-elt (seq n val)
+ − 206 (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
+ − 207
+ − 208 (defun cl-set-nthcdr (n list x)
+ − 209 (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
+ − 210
+ − 211 (defun cl-set-buffer-substring (start end val)
+ − 212 (save-excursion (delete-region start end)
+ − 213 (goto-char start)
+ − 214 (insert val)
+ − 215 val))
+ − 216
+ − 217 (defun cl-set-substring (str start end val)
+ − 218 (if end (if (< end 0) (incf end (length str)))
+ − 219 (setq end (length str)))
+ − 220 (if (< start 0) (incf start str))
+ − 221 (concat (and (> start 0) (substring str 0 start))
+ − 222 val
+ − 223 (and (< end (length str)) (substring str end))))
+ − 224
+ − 225
+ − 226 ;;; Control structures.
+ − 227
+ − 228 ;; The macros `when' and `unless' are so useful that we want them to
+ − 229 ;; ALWAYS be available. So they've been moved from cl.el to eval.c.
+ − 230 ;; Note: FSF Emacs moved them to subr.el in FSF 20.
+ − 231
+ − 232 (defun cl-map-extents (&rest cl-args)
+ − 233 ;; XEmacs: This used to check for overlays first, but that's wrong
+ − 234 ;; because of the new compatibility library. *duh*
+ − 235 (cond ((fboundp 'map-extents)
+ − 236 (apply 'map-extents cl-args))
+ − 237 ((fboundp 'next-overlay-at)
+ − 238 (apply 'cl-map-overlays cl-args))))
+ − 239
+ − 240
+ − 241 ;;; Blocks and exits.
+ − 242
+ − 243 (defalias 'cl-block-wrapper 'identity)
+ − 244 (defalias 'cl-block-throw 'throw)
+ − 245
+ − 246
+ − 247 ;;; Multiple values. True multiple values are not supported, or even
+ − 248 ;;; simulated. Instead, multiple-value-bind and friends simply expect
+ − 249 ;;; the target form to return the values as a list.
+ − 250
+ − 251 (defalias 'values 'list)
+ − 252 (defalias 'values-list 'identity)
+ − 253 (defalias 'multiple-value-list 'identity)
+ − 254 (defalias 'multiple-value-call 'apply) ; only works for one arg
+ − 255 (defalias 'nth-value 'nth)
+ − 256
+ − 257
+ − 258 ;;; Macros.
+ − 259
+ − 260 (defvar cl-macro-environment nil)
+ − 261 ;; XEmacs: we renamed the internal function to macroexpand-internal
+ − 262 ;; to avoid doc-file problems.
+ − 263 (defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand-internal)
+ − 264 (defalias 'macroexpand 'cl-macroexpand)))
+ − 265
+ − 266 (defun cl-macroexpand (cl-macro &optional cl-env)
+ − 267 "Return result of expanding macros at top level of FORM.
+ − 268 If FORM is not a macro call, it is returned unchanged.
+ − 269 Otherwise, the macro is expanded and the expansion is considered
+ − 270 in place of FORM. When a non-macro-call results, it is returned.
+ − 271
442
+ − 272 The second optional arg ENVIRONMENT specifies an environment of macro
428
+ − 273 definitions to shadow the loaded ones for use in file byte-compilation."
+ − 274 (let ((cl-macro-environment cl-env))
+ − 275 (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
+ − 276 (and (symbolp cl-macro)
+ − 277 (cdr (assq (symbol-name cl-macro) cl-env))))
+ − 278 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))
+ − 279 cl-macro))
+ − 280
+ − 281
+ − 282 ;;; Declarations.
+ − 283
+ − 284 (defvar cl-compiling-file nil)
+ − 285 (defun cl-compiling-file ()
+ − 286 (or cl-compiling-file
+ − 287 ;; XEmacs change
+ − 288 ; (and (boundp 'outbuffer) (bufferp (symbol-value 'outbuffer))
+ − 289 ; (equal (buffer-name (symbol-value 'outbuffer))
+ − 290 ; " *Compiler Output*"))
+ − 291 (and (boundp 'byte-compile-outbuffer)
+ − 292 (bufferp (symbol-value 'byte-compile-outbuffer))
+ − 293 (equal (buffer-name (symbol-value 'byte-compile-outbuffer))
+ − 294 " *Compiler Output*"))
+ − 295 ))
+ − 296
+ − 297 (defvar cl-proclaims-deferred nil)
+ − 298
+ − 299 (defun proclaim (spec)
+ − 300 (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
+ − 301 (push spec cl-proclaims-deferred))
+ − 302 nil)
+ − 303
+ − 304 (defmacro declaim (&rest specs)
+ − 305 (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x))))
+ − 306 specs)))
+ − 307 (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body)
+ − 308 (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when
+ − 309
+ − 310
+ − 311 ;;; Symbols.
+ − 312
+ − 313 (defun cl-random-time ()
+ − 314 (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
+ − 315 (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i))))
+ − 316 v))
+ − 317
+ − 318 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100))
+ − 319
442
+ − 320 (defun gensym (&optional arg)
+ − 321 "Generate a new uninterned symbol.
+ − 322 The name is made by appending a number to PREFIX, default \"G\"."
+ − 323 (let ((prefix (if (stringp arg) arg "G"))
+ − 324 (num (if (integerp arg) arg
+ − 325 (prog1 *gensym-counter*
+ − 326 (setq *gensym-counter* (1+ *gensym-counter*))))))
+ − 327 (make-symbol (format "%s%d" prefix num))))
+ − 328
+ − 329 (defun gentemp (&optional arg)
+ − 330 "Generate a new interned symbol with a unique name.
+ − 331 The name is made by appending a number to PREFIX, default \"G\"."
+ − 332 (let ((prefix (if (stringp arg) arg "G"))
+ − 333 name)
+ − 334 (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*)))
+ − 335 (setq *gensym-counter* (1+ *gensym-counter*)))
+ − 336 (intern name)))
428
+ − 337
+ − 338 ;;; Numbers.
+ − 339
446
+ − 340 (defun floatp-safe (object)
+ − 341 "Return t if OBJECT is a floating point number."
+ − 342 (floatp object))
428
+ − 343
446
+ − 344 (defun plusp (number)
428
+ − 345 "Return t if NUMBER is positive."
446
+ − 346 (> number 0))
+ − 347
+ − 348 (defun minusp (number)
+ − 349 "Return t if NUMBER is negative."
+ − 350 (< number 0))
428
+ − 351
446
+ − 352 (defun oddp (integer)
428
+ − 353 "Return t if INTEGER is odd."
446
+ − 354 (eq (logand integer 1) 1))
428
+ − 355
446
+ − 356 (defun evenp (integer)
428
+ − 357 "Return t if INTEGER is even."
446
+ − 358 (eq (logand integer 1) 0))
428
+ − 359
446
+ − 360 (defun cl-abs (number)
+ − 361 "Return the absolute value of NUMBER."
+ − 362 (if (>= number 0) number (- number)))
428
+ − 363 (or (fboundp 'abs) (defalias 'abs 'cl-abs)) ; This is built-in to Emacs 19
+ − 364
+ − 365 (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time)))
+ − 366
+ − 367 ;;; We use `eval' in case VALBITS differs from compile-time to load-time.
+ − 368 (defconst most-positive-fixnum (eval '(lsh -1 -1))
+ − 369 "The integer closest in value to positive infinity.")
+ − 370 (defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1)))
+ − 371 "The integer closest in value to negative infinity.")
+ − 372
+ − 373 ;;; The following are set by code in cl-extra.el
+ − 374 (defconst most-positive-float nil
+ − 375 "The float closest in value to positive infinity.")
+ − 376 (defconst most-negative-float nil
+ − 377 "The float closest in value to negative infinity.")
+ − 378 (defconst least-positive-float nil
+ − 379 "The positive float closest in value to 0.")
+ − 380 (defconst least-negative-float nil
+ − 381 "The negative float closest in value to 0.")
+ − 382 (defconst least-positive-normalized-float nil)
+ − 383 (defconst least-negative-normalized-float nil)
+ − 384 (defconst float-epsilon nil)
+ − 385 (defconst float-negative-epsilon nil)
+ − 386
+ − 387
+ − 388 ;;; Sequence functions.
+ − 389
+ − 390 (defalias 'copy-seq 'copy-sequence)
+ − 391
+ − 392 (defun mapcar* (cl-func cl-x &rest cl-rest)
+ − 393 "Apply FUNCTION to each element of SEQ, and make a list of the results.
+ − 394 If there are several SEQs, FUNCTION is called with that many arguments,
+ − 395 and mapping stops as soon as the shortest list runs out. With just one
+ − 396 SEQ, this is like `mapcar'. With several, it is like the Common Lisp
+ − 397 `mapcar' function extended to arbitrary sequence types."
+ − 398 (if cl-rest
+ − 399 (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
+ − 400 (cl-mapcar-many cl-func (cons cl-x cl-rest))
+ − 401 (let ((cl-res nil) (cl-y (car cl-rest)))
+ − 402 (while (and cl-x cl-y)
+ − 403 (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
+ − 404 (nreverse cl-res)))
+ − 405 (mapcar cl-func cl-x)))
+ − 406
+ − 407
+ − 408 ;;; List functions.
+ − 409
+ − 410 ;; These functions are made known to the byte-compiler by cl-macs.el
+ − 411 ;; and turned into efficient car and cdr bytecodes.
+ − 412
+ − 413 (defalias 'first 'car)
+ − 414 (defalias 'rest 'cdr)
+ − 415 (defalias 'endp 'null)
+ − 416
+ − 417 (defun second (x)
+ − 418 "Return the second element of the list LIST."
+ − 419 (car (cdr x)))
+ − 420
+ − 421 (defun third (x)
+ − 422 "Return the third element of the list LIST."
+ − 423 (car (cdr (cdr x))))
+ − 424
+ − 425 (defun fourth (x)
+ − 426 "Return the fourth element of the list LIST."
+ − 427 (nth 3 x))
+ − 428
+ − 429 (defun fifth (x)
+ − 430 "Return the fifth element of the list LIST."
+ − 431 (nth 4 x))
+ − 432
+ − 433 (defun sixth (x)
+ − 434 "Return the sixth element of the list LIST."
+ − 435 (nth 5 x))
+ − 436
+ − 437 (defun seventh (x)
+ − 438 "Return the seventh element of the list LIST."
+ − 439 (nth 6 x))
+ − 440
+ − 441 (defun eighth (x)
+ − 442 "Return the eighth element of the list LIST."
+ − 443 (nth 7 x))
+ − 444
+ − 445 (defun ninth (x)
+ − 446 "Return the ninth element of the list LIST."
+ − 447 (nth 8 x))
+ − 448
+ − 449 (defun tenth (x)
+ − 450 "Return the tenth element of the list LIST."
+ − 451 (nth 9 x))
+ − 452
+ − 453 (defun caar (x)
+ − 454 "Return the `car' of the `car' of X."
+ − 455 (car (car x)))
+ − 456
+ − 457 (defun cadr (x)
+ − 458 "Return the `car' of the `cdr' of X."
+ − 459 (car (cdr x)))
+ − 460
+ − 461 (defun cdar (x)
+ − 462 "Return the `cdr' of the `car' of X."
+ − 463 (cdr (car x)))
+ − 464
+ − 465 (defun cddr (x)
+ − 466 "Return the `cdr' of the `cdr' of X."
+ − 467 (cdr (cdr x)))
+ − 468
+ − 469 (defun caaar (x)
+ − 470 "Return the `car' of the `car' of the `car' of X."
+ − 471 (car (car (car x))))
+ − 472
+ − 473 (defun caadr (x)
+ − 474 "Return the `car' of the `car' of the `cdr' of X."
+ − 475 (car (car (cdr x))))
+ − 476
+ − 477 (defun cadar (x)
+ − 478 "Return the `car' of the `cdr' of the `car' of X."
+ − 479 (car (cdr (car x))))
+ − 480
+ − 481 (defun caddr (x)
+ − 482 "Return the `car' of the `cdr' of the `cdr' of X."
+ − 483 (car (cdr (cdr x))))
+ − 484
+ − 485 (defun cdaar (x)
+ − 486 "Return the `cdr' of the `car' of the `car' of X."
+ − 487 (cdr (car (car x))))
+ − 488
+ − 489 (defun cdadr (x)
+ − 490 "Return the `cdr' of the `car' of the `cdr' of X."
+ − 491 (cdr (car (cdr x))))
+ − 492
+ − 493 (defun cddar (x)
+ − 494 "Return the `cdr' of the `cdr' of the `car' of X."
+ − 495 (cdr (cdr (car x))))
+ − 496
+ − 497 (defun cdddr (x)
+ − 498 "Return the `cdr' of the `cdr' of the `cdr' of X."
+ − 499 (cdr (cdr (cdr x))))
+ − 500
+ − 501 (defun caaaar (x)
+ − 502 "Return the `car' of the `car' of the `car' of the `car' of X."
+ − 503 (car (car (car (car x)))))
+ − 504
+ − 505 (defun caaadr (x)
+ − 506 "Return the `car' of the `car' of the `car' of the `cdr' of X."
+ − 507 (car (car (car (cdr x)))))
+ − 508
+ − 509 (defun caadar (x)
+ − 510 "Return the `car' of the `car' of the `cdr' of the `car' of X."
+ − 511 (car (car (cdr (car x)))))
+ − 512
+ − 513 (defun caaddr (x)
+ − 514 "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
+ − 515 (car (car (cdr (cdr x)))))
+ − 516
+ − 517 (defun cadaar (x)
+ − 518 "Return the `car' of the `cdr' of the `car' of the `car' of X."
+ − 519 (car (cdr (car (car x)))))
+ − 520
+ − 521 (defun cadadr (x)
+ − 522 "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
+ − 523 (car (cdr (car (cdr x)))))
+ − 524
+ − 525 (defun caddar (x)
+ − 526 "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
+ − 527 (car (cdr (cdr (car x)))))
+ − 528
+ − 529 (defun cadddr (x)
+ − 530 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
+ − 531 (car (cdr (cdr (cdr x)))))
+ − 532
+ − 533 (defun cdaaar (x)
+ − 534 "Return the `cdr' of the `car' of the `car' of the `car' of X."
+ − 535 (cdr (car (car (car x)))))
+ − 536
+ − 537 (defun cdaadr (x)
+ − 538 "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
+ − 539 (cdr (car (car (cdr x)))))
+ − 540
+ − 541 (defun cdadar (x)
+ − 542 "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
+ − 543 (cdr (car (cdr (car x)))))
+ − 544
+ − 545 (defun cdaddr (x)
+ − 546 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
+ − 547 (cdr (car (cdr (cdr x)))))
+ − 548
+ − 549 (defun cddaar (x)
+ − 550 "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
+ − 551 (cdr (cdr (car (car x)))))
+ − 552
+ − 553 (defun cddadr (x)
+ − 554 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
+ − 555 (cdr (cdr (car (cdr x)))))
+ − 556
+ − 557 (defun cdddar (x)
+ − 558 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
+ − 559 (cdr (cdr (cdr (car x)))))
+ − 560
+ − 561 (defun cddddr (x)
+ − 562 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
+ − 563 (cdr (cdr (cdr (cdr x)))))
+ − 564
+ − 565 ;;; `last' is implemented as a C primitive, as of 1998-11
+ − 566
+ − 567 ;(defun last (x &optional n)
+ − 568 ; "Return the last link in the list LIST.
+ − 569 ;With optional argument N, return Nth-to-last link (default 1)."
+ − 570 ; (if n
+ − 571 ; (let ((m 0) (p x))
+ − 572 ; (while (consp p) (incf m) (pop p))
+ − 573 ; (if (<= n 0) p
+ − 574 ; (if (< n m) (nthcdr (- m n) x) x)))
+ − 575 ; (while (consp (cdr x)) (pop x))
+ − 576 ; x))
+ − 577
+ − 578 ;;; `butlast' is implemented as a C primitive, as of 1998-11
+ − 579 ;;; `nbutlast' is implemented as a C primitive, as of 1998-11
+ − 580
+ − 581 ;(defun butlast (x &optional n)
+ − 582 ; "Return a copy of LIST with the last N elements removed."
+ − 583 ; (if (and n (<= n 0)) x
+ − 584 ; (nbutlast (copy-sequence x) n)))
+ − 585
+ − 586 ;(defun nbutlast (x &optional n)
+ − 587 ; "Modify LIST to remove the last N elements."
+ − 588 ; (let ((m (length x)))
+ − 589 ; (or n (setq n 1))
+ − 590 ; (and (< n m)
+ − 591 ; (progn
+ − 592 ; (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
+ − 593 ; x))))
+ − 594
+ − 595 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el
+ − 596 "Return a new list with specified args as elements, cons'd to last arg.
+ − 597 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
+ − 598 `(cons A (cons B (cons C D)))'."
+ − 599 (cond ((not rest) arg)
+ − 600 ((not (cdr rest)) (cons arg (car rest)))
+ − 601 (t (let* ((n (length rest))
+ − 602 (copy (copy-sequence rest))
+ − 603 (last (nthcdr (- n 2) copy)))
+ − 604 (setcdr last (car (cdr last)))
+ − 605 (cons arg copy)))))
+ − 606
+ − 607 (defun ldiff (list sublist)
+ − 608 "Return a copy of LIST with the tail SUBLIST removed."
+ − 609 (let ((res nil))
+ − 610 (while (and (consp list) (not (eq list sublist)))
+ − 611 (push (pop list) res))
+ − 612 (nreverse res)))
+ − 613
+ − 614 ;;; `copy-list' is implemented as a C primitive, as of 1998-11
+ − 615
+ − 616 ;(defun copy-list (list)
+ − 617 ; "Return a copy of a list, which may be a dotted list.
+ − 618 ;The elements of the list are not copied, just the list structure itself."
+ − 619 ; (if (consp list)
+ − 620 ; (let ((res nil))
+ − 621 ; (while (consp list) (push (pop list) res))
+ − 622 ; (prog1 (nreverse res) (setcdr res list)))
+ − 623 ; (car list)))
+ − 624
+ − 625 (defun cl-maclisp-member (item list)
+ − 626 (while (and list (not (equal item (car list)))) (setq list (cdr list)))
+ − 627 list)
+ − 628
+ − 629 ;;; Define an Emacs 19-compatible `member' for the benefit of Emacs 18 users.
+ − 630 (or (and (fboundp 'member) (subrp (symbol-function 'member)))
+ − 631 (defalias 'member 'cl-maclisp-member))
+ − 632
+ − 633 (defalias 'cl-member 'memq) ; for compatibility with old CL package
+ − 634 (defalias 'cl-floor 'floor*)
+ − 635 (defalias 'cl-ceiling 'ceiling*)
+ − 636 (defalias 'cl-truncate 'truncate*)
+ − 637 (defalias 'cl-round 'round*)
+ − 638 (defalias 'cl-mod 'mod*)
+ − 639
+ − 640 (defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs
+ − 641 "Return ITEM consed onto the front of LIST only if it's not already there.
+ − 642 Otherwise, return LIST unmodified.
+ − 643 Keywords supported: :test :test-not :key"
+ − 644 (cond ((or (equal cl-keys '(:test eq))
+ − 645 (and (null cl-keys) (not (numberp cl-item))))
+ − 646 (if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
+ − 647 ((or (equal cl-keys '(:test equal)) (null cl-keys))
+ − 648 (if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
+ − 649 (t (apply 'cl-adjoin cl-item cl-list cl-keys))))
+ − 650
+ − 651 (defun subst (cl-new cl-old cl-tree &rest cl-keys)
+ − 652 "Substitute NEW for OLD everywhere in TREE (non-destructively).
+ − 653 Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
+ − 654 Keywords supported: :test :test-not :key"
+ − 655 (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
+ − 656 (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
+ − 657 (cl-do-subst cl-new cl-old cl-tree)))
+ − 658
+ − 659 (defun cl-do-subst (cl-new cl-old cl-tree)
+ − 660 (cond ((eq cl-tree cl-old) cl-new)
+ − 661 ((consp cl-tree)
+ − 662 (let ((a (cl-do-subst cl-new cl-old (car cl-tree)))
+ − 663 (d (cl-do-subst cl-new cl-old (cdr cl-tree))))
+ − 664 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
+ − 665 cl-tree (cons a d))))
+ − 666 (t cl-tree)))
+ − 667
+ − 668 (defun acons (a b c)
+ − 669 "Return a new alist created by adding (KEY . VALUE) to ALIST."
+ − 670 (cons (cons a b) c))
+ − 671
+ − 672 (defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c))
+ − 673
+ − 674
+ − 675 ;;; Miscellaneous.
+ − 676
+ − 677 ;; XEmacs change
+ − 678 (define-error 'cl-assertion-failed "Assertion failed")
+ − 679
+ − 680 ;;; This is defined in Emacs 19; define it here for Emacs 18 users.
+ − 681 (defun cl-add-hook (hook func &optional append)
+ − 682 "Add to hook variable HOOK the function FUNC.
+ − 683 FUNC is not added if it already appears on the list stored in HOOK."
+ − 684 (let ((old (and (boundp hook) (symbol-value hook))))
+ − 685 (and (listp old) (not (eq (car old) 'lambda))
+ − 686 (setq old (list old)))
+ − 687 (and (not (member func old))
+ − 688 (set hook (if append (nconc old (list func)) (cons func old))))))
+ − 689 (or (fboundp 'add-hook) (defalias 'add-hook 'cl-add-hook))
+ − 690
+ − 691 ;; XEmacs change
+ − 692 ;(load "cl-defs")
+ − 693
+ − 694 ;;; Define data for indentation and edebug.
+ − 695 (mapcar
+ − 696 #'(lambda (entry)
+ − 697 (mapcar
+ − 698 #'(lambda (func)
+ − 699 (put func 'lisp-indent-function (nth 1 entry))
+ − 700 (put func 'lisp-indent-hook (nth 1 entry))
+ − 701 (or (get func 'edebug-form-spec)
+ − 702 (put func 'edebug-form-spec (nth 2 entry))))
+ − 703 (car entry)))
+ − 704 '(((defun* defmacro*) defun)
+ − 705 ((function*) nil
+ − 706 (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form)))
+ − 707 ((eval-when) 1 (sexp &rest form))
+ − 708 ((when unless) 1 (&rest form))
+ − 709 ((declare) nil (&rest sexp))
+ − 710 ((the) 1 (sexp &rest form))
+ − 711 ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form)))
+ − 712 ((block return-from) 1 (sexp &rest form))
+ − 713 ((return) nil (&optional form))
+ − 714 ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form))
+ − 715 (form &rest form)
+ − 716 &rest form))
+ − 717 ((dolist dotimes) 1 ((symbolp form &rest form) &rest form))
+ − 718 ((do-symbols) 1 ((symbolp form &optional form form) &rest form))
+ − 719 ((do-all-symbols) 1 ((symbolp form &optional form) &rest form))
+ − 720 ((psetq setf psetf) nil edebug-setq-form)
+ − 721 ((progv) 2 (&rest form))
+ − 722 ((flet labels macrolet) 1
+ − 723 ((&rest (sexp sexp &rest form)) &rest form))
+ − 724 ((symbol-macrolet lexical-let lexical-let*) 1
+ − 725 ((&rest &or symbolp (symbolp form)) &rest form))
+ − 726 ((multiple-value-bind) 2 ((&rest symbolp) &rest form))
+ − 727 ((multiple-value-setq) 1 ((&rest symbolp) &rest form))
+ − 728 ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form))
+ − 729 ((letf letf*) 1 ((&rest (&rest form)) &rest form))
+ − 730 ((callf destructuring-bind) 2 (sexp form &rest form))
+ − 731 ((callf2) 3 (sexp form form &rest form))
+ − 732 ((loop) defun (&rest &or symbolp form))
+ − 733 ((ignore-errors) 0 (&rest form))))
+ − 734
+ − 735
+ − 736 ;;; This goes here so that cl-macs can find it if it loads right now.
+ − 737 (provide 'cl-19) ; usage: (require 'cl-19 "cl")
+ − 738
+ − 739
+ − 740 ;;; Things to do after byte-compiler is loaded.
+ − 741 ;;; As a side effect, we cause cl-macs to be loaded when compiling, so
+ − 742 ;;; that the compiler-macros defined there will be present.
+ − 743
+ − 744 (defvar cl-hacked-flag nil)
+ − 745 (defun cl-hack-byte-compiler ()
+ − 746 (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form))
+ − 747 (progn
442
+ − 748 (when (not (fboundp 'cl-compile-time-init))
+ − 749 (load "cl-macs" nil t))
428
+ − 750 (cl-compile-time-init) ; in cl-macs.el
+ − 751 (setq cl-hacked-flag t))))
+ − 752
+ − 753 ;;; Try it now in case the compiler has already been loaded.
+ − 754 (cl-hack-byte-compiler)
+ − 755
+ − 756 ;;; Also make a hook in case compiler is loaded after this file.
+ − 757 ;;; The compiler doesn't call any hooks when it loads or runs, but
+ − 758 ;;; we can take advantage of the fact that emacs-lisp-mode will be
+ − 759 ;;; called when the compiler reads in the file to be compiled.
+ − 760 ;;; BUG: If the first compilation is `byte-compile' rather than
+ − 761 ;;; `byte-compile-file', we lose. Oh, well.
+ − 762 (add-hook 'emacs-lisp-mode-hook 'cl-hack-byte-compiler)
+ − 763
+ − 764
+ − 765 ;;; The following ensures that packages which expect the old-style cl.el
+ − 766 ;;; will be happy with this one.
+ − 767
+ − 768 (provide 'cl)
+ − 769
+ − 770 (provide 'mini-cl) ; for Epoch
+ − 771
+ − 772 (run-hooks 'cl-load-hook)
+ − 773
+ − 774 ;;; cl.el ends here