|
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'."
|
|
1983
|
154 (or (eq a b)
|
|
|
155 (and (numberp a) (numberp b) (equal a b))))
|
|
428
|
156
|
|
|
157 ;;; Generalized variables. These macros are defined here so that they
|
|
|
158 ;;; can safely be used in .emacs files.
|
|
|
159
|
|
|
160 (defmacro incf (place &optional x)
|
|
|
161 "(incf PLACE [X]): increment PLACE by X (1 by default).
|
|
|
162 PLACE may be a symbol, or any generalized variable allowed by `setf'.
|
|
|
163 The return value is the incremented value of PLACE."
|
|
|
164 (if (symbolp place)
|
|
|
165 (list 'setq place (if x (list '+ place x) (list '1+ place)))
|
|
|
166 ;; XEmacs byte-compiler optimizes (+ FOO 1) to (1+ FOO), so this
|
|
|
167 ;; is OK.
|
|
|
168 (list 'callf '+ place (or x 1))))
|
|
|
169
|
|
|
170 (defmacro decf (place &optional x)
|
|
|
171 "(decf PLACE [X]): decrement PLACE by X (1 by default).
|
|
|
172 PLACE may be a symbol, or any generalized variable allowed by `setf'.
|
|
|
173 The return value is the decremented value of PLACE."
|
|
|
174 (if (symbolp place)
|
|
|
175 (list 'setq place (if x (list '- place x) (list '1- place)))
|
|
|
176 (list 'callf '- place (or x 1))))
|
|
|
177
|
|
|
178 (defmacro pop (place)
|
|
|
179 "(pop PLACE): remove and return the head of the list stored in PLACE.
|
|
|
180 Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more
|
|
|
181 careful about evaluating each argument only once and in the right order.
|
|
|
182 PLACE may be a symbol, or any generalized variable allowed by `setf'."
|
|
|
183 (if (symbolp place)
|
|
|
184 `(car (prog1 ,place (setq ,place (cdr ,place))))
|
|
|
185 (cl-do-pop place)))
|
|
|
186
|
|
|
187 (defmacro push (x place)
|
|
|
188 "(push X PLACE): insert X at the head of the list stored in PLACE.
|
|
|
189 Analogous to (setf PLACE (cons X PLACE)), though more careful about
|
|
|
190 evaluating each argument only once and in the right order. PLACE may
|
|
|
191 be a symbol, or any generalized variable allowed by `setf'."
|
|
|
192 (if (symbolp place) `(setq ,place (cons ,x ,place))
|
|
|
193 (list 'callf2 'cons x place)))
|
|
|
194
|
|
|
195 (defmacro pushnew (x place &rest keys)
|
|
|
196 "(pushnew X PLACE): insert X at the head of the list if not already there.
|
|
|
197 Like (push X PLACE), except that the list is unmodified if X is `eql' to
|
|
|
198 an element already on the list.
|
|
|
199 Keywords supported: :test :test-not :key"
|
|
|
200 (if (symbolp place) (list 'setq place (list* 'adjoin x place keys))
|
|
|
201 (list* 'callf2 'adjoin x place keys)))
|
|
|
202
|
|
|
203 (defun cl-set-elt (seq n val)
|
|
|
204 (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
|
|
|
205
|
|
|
206 (defun cl-set-nthcdr (n list x)
|
|
|
207 (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
|
|
|
208
|
|
|
209 (defun cl-set-buffer-substring (start end val)
|
|
|
210 (save-excursion (delete-region start end)
|
|
|
211 (goto-char start)
|
|
|
212 (insert val)
|
|
|
213 val))
|
|
|
214
|
|
|
215 (defun cl-set-substring (str start end val)
|
|
|
216 (if end (if (< end 0) (incf end (length str)))
|
|
|
217 (setq end (length str)))
|
|
2136
|
218 (if (< start 0) (incf start (length str)))
|
|
428
|
219 (concat (and (> start 0) (substring str 0 start))
|
|
|
220 val
|
|
|
221 (and (< end (length str)) (substring str end))))
|
|
|
222
|
|
|
223
|
|
|
224 ;;; Control structures.
|
|
|
225
|
|
|
226 ;; The macros `when' and `unless' are so useful that we want them to
|
|
|
227 ;; ALWAYS be available. So they've been moved from cl.el to eval.c.
|
|
|
228 ;; Note: FSF Emacs moved them to subr.el in FSF 20.
|
|
|
229
|
|
|
230 (defun cl-map-extents (&rest cl-args)
|
|
|
231 ;; XEmacs: This used to check for overlays first, but that's wrong
|
|
|
232 ;; because of the new compatibility library. *duh*
|
|
|
233 (cond ((fboundp 'map-extents)
|
|
|
234 (apply 'map-extents cl-args))
|
|
|
235 ((fboundp 'next-overlay-at)
|
|
|
236 (apply 'cl-map-overlays cl-args))))
|
|
|
237
|
|
|
238
|
|
|
239 ;;; Blocks and exits.
|
|
|
240
|
|
|
241 (defalias 'cl-block-wrapper 'identity)
|
|
|
242 (defalias 'cl-block-throw 'throw)
|
|
|
243
|
|
|
244
|
|
|
245 ;;; Multiple values. True multiple values are not supported, or even
|
|
|
246 ;;; simulated. Instead, multiple-value-bind and friends simply expect
|
|
|
247 ;;; the target form to return the values as a list.
|
|
|
248
|
|
|
249 (defalias 'values 'list)
|
|
|
250 (defalias 'values-list 'identity)
|
|
|
251 (defalias 'multiple-value-list 'identity)
|
|
|
252 (defalias 'multiple-value-call 'apply) ; only works for one arg
|
|
|
253 (defalias 'nth-value 'nth)
|
|
|
254
|
|
|
255
|
|
|
256 ;;; Macros.
|
|
|
257
|
|
|
258 (defvar cl-macro-environment nil)
|
|
|
259 ;; XEmacs: we renamed the internal function to macroexpand-internal
|
|
|
260 ;; to avoid doc-file problems.
|
|
|
261 (defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand-internal)
|
|
|
262 (defalias 'macroexpand 'cl-macroexpand)))
|
|
|
263
|
|
|
264 (defun cl-macroexpand (cl-macro &optional cl-env)
|
|
|
265 "Return result of expanding macros at top level of FORM.
|
|
|
266 If FORM is not a macro call, it is returned unchanged.
|
|
|
267 Otherwise, the macro is expanded and the expansion is considered
|
|
|
268 in place of FORM. When a non-macro-call results, it is returned.
|
|
|
269
|
|
442
|
270 The second optional arg ENVIRONMENT specifies an environment of macro
|
|
428
|
271 definitions to shadow the loaded ones for use in file byte-compilation."
|
|
|
272 (let ((cl-macro-environment cl-env))
|
|
|
273 (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
|
|
|
274 (and (symbolp cl-macro)
|
|
|
275 (cdr (assq (symbol-name cl-macro) cl-env))))
|
|
|
276 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))
|
|
|
277 cl-macro))
|
|
|
278
|
|
|
279
|
|
|
280 ;;; Declarations.
|
|
|
281
|
|
|
282 (defvar cl-compiling-file nil)
|
|
|
283 (defun cl-compiling-file ()
|
|
|
284 (or cl-compiling-file
|
|
|
285 ;; XEmacs change
|
|
|
286 ; (and (boundp 'outbuffer) (bufferp (symbol-value 'outbuffer))
|
|
|
287 ; (equal (buffer-name (symbol-value 'outbuffer))
|
|
|
288 ; " *Compiler Output*"))
|
|
|
289 (and (boundp 'byte-compile-outbuffer)
|
|
|
290 (bufferp (symbol-value 'byte-compile-outbuffer))
|
|
|
291 (equal (buffer-name (symbol-value 'byte-compile-outbuffer))
|
|
|
292 " *Compiler Output*"))
|
|
|
293 ))
|
|
|
294
|
|
|
295 (defvar cl-proclaims-deferred nil)
|
|
|
296
|
|
|
297 (defun proclaim (spec)
|
|
|
298 (if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
|
|
|
299 (push spec cl-proclaims-deferred))
|
|
|
300 nil)
|
|
|
301
|
|
|
302 (defmacro declaim (&rest specs)
|
|
|
303 (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x))))
|
|
|
304 specs)))
|
|
|
305 (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body)
|
|
|
306 (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when
|
|
|
307
|
|
|
308
|
|
|
309 ;;; Symbols.
|
|
|
310
|
|
|
311 (defun cl-random-time ()
|
|
|
312 (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
|
|
|
313 (while (>= (decf i) 0) (setq v (+ (* v 3) (aref time i))))
|
|
2092
|
314 (if (featurep 'bignum)
|
|
1983
|
315 (coerce-number v 'fixnum)
|
|
|
316 v)))
|
|
428
|
317
|
|
|
318 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100))
|
|
|
319
|
|
442
|
320 (defun gensym (&optional arg)
|
|
|
321 "Generate a new uninterned symbol.
|
|
2071
|
322 The name is made by appending a number to a prefix. If ARG is a string, it
|
|
|
323 is the prefix, otherwise the prefix defaults to \"G\". If ARG is an integer,
|
|
|
324 the internal counter is reset to that number before creating the name.
|
|
|
325 There is no way to specify both using this function."
|
|
442
|
326 (let ((prefix (if (stringp arg) arg "G"))
|
|
|
327 (num (if (integerp arg) arg
|
|
|
328 (prog1 *gensym-counter*
|
|
|
329 (setq *gensym-counter* (1+ *gensym-counter*))))))
|
|
|
330 (make-symbol (format "%s%d" prefix num))))
|
|
|
331
|
|
|
332 (defun gentemp (&optional arg)
|
|
|
333 "Generate a new interned symbol with a unique name.
|
|
2071
|
334 The name is made by appending a number to ARG, default \"G\".
|
|
|
335 If ARG is not a string, it is ignored."
|
|
442
|
336 (let ((prefix (if (stringp arg) arg "G"))
|
|
|
337 name)
|
|
|
338 (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*)))
|
|
|
339 (setq *gensym-counter* (1+ *gensym-counter*)))
|
|
|
340 (intern name)))
|
|
428
|
341
|
|
|
342 ;;; Numbers.
|
|
|
343
|
|
446
|
344 (defun floatp-safe (object)
|
|
|
345 "Return t if OBJECT is a floating point number."
|
|
|
346 (floatp object))
|
|
428
|
347
|
|
446
|
348 (defun plusp (number)
|
|
428
|
349 "Return t if NUMBER is positive."
|
|
446
|
350 (> number 0))
|
|
|
351
|
|
|
352 (defun minusp (number)
|
|
|
353 "Return t if NUMBER is negative."
|
|
|
354 (< number 0))
|
|
428
|
355
|
|
446
|
356 (defun oddp (integer)
|
|
428
|
357 "Return t if INTEGER is odd."
|
|
446
|
358 (eq (logand integer 1) 1))
|
|
428
|
359
|
|
446
|
360 (defun evenp (integer)
|
|
428
|
361 "Return t if INTEGER is even."
|
|
446
|
362 (eq (logand integer 1) 0))
|
|
428
|
363
|
|
446
|
364 (defun cl-abs (number)
|
|
|
365 "Return the absolute value of NUMBER."
|
|
|
366 (if (>= number 0) number (- number)))
|
|
428
|
367 (or (fboundp 'abs) (defalias 'abs 'cl-abs)) ; This is built-in to Emacs 19
|
|
|
368
|
|
|
369 (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time)))
|
|
|
370
|
|
1983
|
371 ;; These constants are defined in C when 'number-types is provided.
|
|
|
372 (unless (featurep 'number-types)
|
|
428
|
373 ;;; We use `eval' in case VALBITS differs from compile-time to load-time.
|
|
1983
|
374 (defconst most-positive-fixnum (eval '(lsh -1 -1))
|
|
|
375 "The integer closest in value to positive infinity.")
|
|
|
376 (defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1)))
|
|
|
377 "The integer closest in value to negative infinity."))
|
|
428
|
378
|
|
|
379 ;;; The following are set by code in cl-extra.el
|
|
|
380 (defconst most-positive-float nil
|
|
|
381 "The float closest in value to positive infinity.")
|
|
|
382 (defconst most-negative-float nil
|
|
|
383 "The float closest in value to negative infinity.")
|
|
|
384 (defconst least-positive-float nil
|
|
|
385 "The positive float closest in value to 0.")
|
|
|
386 (defconst least-negative-float nil
|
|
|
387 "The negative float closest in value to 0.")
|
|
|
388 (defconst least-positive-normalized-float nil)
|
|
|
389 (defconst least-negative-normalized-float nil)
|
|
|
390 (defconst float-epsilon nil)
|
|
|
391 (defconst float-negative-epsilon nil)
|
|
|
392
|
|
|
393
|
|
|
394 ;;; Sequence functions.
|
|
|
395
|
|
|
396 (defalias 'copy-seq 'copy-sequence)
|
|
|
397
|
|
|
398 (defun mapcar* (cl-func cl-x &rest cl-rest)
|
|
|
399 "Apply FUNCTION to each element of SEQ, and make a list of the results.
|
|
|
400 If there are several SEQs, FUNCTION is called with that many arguments,
|
|
|
401 and mapping stops as soon as the shortest list runs out. With just one
|
|
|
402 SEQ, this is like `mapcar'. With several, it is like the Common Lisp
|
|
|
403 `mapcar' function extended to arbitrary sequence types."
|
|
|
404 (if cl-rest
|
|
|
405 (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest)))
|
|
|
406 (cl-mapcar-many cl-func (cons cl-x cl-rest))
|
|
|
407 (let ((cl-res nil) (cl-y (car cl-rest)))
|
|
|
408 (while (and cl-x cl-y)
|
|
|
409 (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
|
|
|
410 (nreverse cl-res)))
|
|
|
411 (mapcar cl-func cl-x)))
|
|
|
412
|
|
|
413
|
|
|
414 ;;; List functions.
|
|
|
415
|
|
|
416 ;; These functions are made known to the byte-compiler by cl-macs.el
|
|
|
417 ;; and turned into efficient car and cdr bytecodes.
|
|
|
418
|
|
|
419 (defalias 'first 'car)
|
|
|
420 (defalias 'rest 'cdr)
|
|
|
421 (defalias 'endp 'null)
|
|
|
422
|
|
|
423 (defun second (x)
|
|
|
424 "Return the second element of the list LIST."
|
|
|
425 (car (cdr x)))
|
|
|
426
|
|
|
427 (defun third (x)
|
|
|
428 "Return the third element of the list LIST."
|
|
|
429 (car (cdr (cdr x))))
|
|
|
430
|
|
|
431 (defun fourth (x)
|
|
|
432 "Return the fourth element of the list LIST."
|
|
|
433 (nth 3 x))
|
|
|
434
|
|
|
435 (defun fifth (x)
|
|
|
436 "Return the fifth element of the list LIST."
|
|
|
437 (nth 4 x))
|
|
|
438
|
|
|
439 (defun sixth (x)
|
|
|
440 "Return the sixth element of the list LIST."
|
|
|
441 (nth 5 x))
|
|
|
442
|
|
|
443 (defun seventh (x)
|
|
|
444 "Return the seventh element of the list LIST."
|
|
|
445 (nth 6 x))
|
|
|
446
|
|
|
447 (defun eighth (x)
|
|
|
448 "Return the eighth element of the list LIST."
|
|
|
449 (nth 7 x))
|
|
|
450
|
|
|
451 (defun ninth (x)
|
|
|
452 "Return the ninth element of the list LIST."
|
|
|
453 (nth 8 x))
|
|
|
454
|
|
|
455 (defun tenth (x)
|
|
|
456 "Return the tenth element of the list LIST."
|
|
|
457 (nth 9 x))
|
|
|
458
|
|
|
459 (defun caar (x)
|
|
|
460 "Return the `car' of the `car' of X."
|
|
|
461 (car (car x)))
|
|
|
462
|
|
|
463 (defun cadr (x)
|
|
|
464 "Return the `car' of the `cdr' of X."
|
|
|
465 (car (cdr x)))
|
|
|
466
|
|
|
467 (defun cdar (x)
|
|
|
468 "Return the `cdr' of the `car' of X."
|
|
|
469 (cdr (car x)))
|
|
|
470
|
|
|
471 (defun cddr (x)
|
|
|
472 "Return the `cdr' of the `cdr' of X."
|
|
|
473 (cdr (cdr x)))
|
|
|
474
|
|
|
475 (defun caaar (x)
|
|
|
476 "Return the `car' of the `car' of the `car' of X."
|
|
|
477 (car (car (car x))))
|
|
|
478
|
|
|
479 (defun caadr (x)
|
|
|
480 "Return the `car' of the `car' of the `cdr' of X."
|
|
|
481 (car (car (cdr x))))
|
|
|
482
|
|
|
483 (defun cadar (x)
|
|
|
484 "Return the `car' of the `cdr' of the `car' of X."
|
|
|
485 (car (cdr (car x))))
|
|
|
486
|
|
|
487 (defun caddr (x)
|
|
|
488 "Return the `car' of the `cdr' of the `cdr' of X."
|
|
|
489 (car (cdr (cdr x))))
|
|
|
490
|
|
|
491 (defun cdaar (x)
|
|
|
492 "Return the `cdr' of the `car' of the `car' of X."
|
|
|
493 (cdr (car (car x))))
|
|
|
494
|
|
|
495 (defun cdadr (x)
|
|
|
496 "Return the `cdr' of the `car' of the `cdr' of X."
|
|
|
497 (cdr (car (cdr x))))
|
|
|
498
|
|
|
499 (defun cddar (x)
|
|
|
500 "Return the `cdr' of the `cdr' of the `car' of X."
|
|
|
501 (cdr (cdr (car x))))
|
|
|
502
|
|
|
503 (defun cdddr (x)
|
|
|
504 "Return the `cdr' of the `cdr' of the `cdr' of X."
|
|
|
505 (cdr (cdr (cdr x))))
|
|
|
506
|
|
|
507 (defun caaaar (x)
|
|
|
508 "Return the `car' of the `car' of the `car' of the `car' of X."
|
|
|
509 (car (car (car (car x)))))
|
|
|
510
|
|
|
511 (defun caaadr (x)
|
|
|
512 "Return the `car' of the `car' of the `car' of the `cdr' of X."
|
|
|
513 (car (car (car (cdr x)))))
|
|
|
514
|
|
|
515 (defun caadar (x)
|
|
|
516 "Return the `car' of the `car' of the `cdr' of the `car' of X."
|
|
|
517 (car (car (cdr (car x)))))
|
|
|
518
|
|
|
519 (defun caaddr (x)
|
|
|
520 "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
|
|
|
521 (car (car (cdr (cdr x)))))
|
|
|
522
|
|
|
523 (defun cadaar (x)
|
|
|
524 "Return the `car' of the `cdr' of the `car' of the `car' of X."
|
|
|
525 (car (cdr (car (car x)))))
|
|
|
526
|
|
|
527 (defun cadadr (x)
|
|
|
528 "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
|
|
|
529 (car (cdr (car (cdr x)))))
|
|
|
530
|
|
|
531 (defun caddar (x)
|
|
|
532 "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
|
|
|
533 (car (cdr (cdr (car x)))))
|
|
|
534
|
|
|
535 (defun cadddr (x)
|
|
|
536 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
|
|
|
537 (car (cdr (cdr (cdr x)))))
|
|
|
538
|
|
|
539 (defun cdaaar (x)
|
|
|
540 "Return the `cdr' of the `car' of the `car' of the `car' of X."
|
|
|
541 (cdr (car (car (car x)))))
|
|
|
542
|
|
|
543 (defun cdaadr (x)
|
|
|
544 "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
|
|
|
545 (cdr (car (car (cdr x)))))
|
|
|
546
|
|
|
547 (defun cdadar (x)
|
|
|
548 "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
|
|
|
549 (cdr (car (cdr (car x)))))
|
|
|
550
|
|
|
551 (defun cdaddr (x)
|
|
|
552 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
|
|
|
553 (cdr (car (cdr (cdr x)))))
|
|
|
554
|
|
|
555 (defun cddaar (x)
|
|
|
556 "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
|
|
|
557 (cdr (cdr (car (car x)))))
|
|
|
558
|
|
|
559 (defun cddadr (x)
|
|
|
560 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
|
|
|
561 (cdr (cdr (car (cdr x)))))
|
|
|
562
|
|
|
563 (defun cdddar (x)
|
|
|
564 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
|
|
|
565 (cdr (cdr (cdr (car x)))))
|
|
|
566
|
|
|
567 (defun cddddr (x)
|
|
|
568 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
|
|
|
569 (cdr (cdr (cdr (cdr x)))))
|
|
|
570
|
|
|
571 ;;; `last' is implemented as a C primitive, as of 1998-11
|
|
|
572
|
|
|
573 ;(defun last (x &optional n)
|
|
|
574 ; "Return the last link in the list LIST.
|
|
|
575 ;With optional argument N, return Nth-to-last link (default 1)."
|
|
|
576 ; (if n
|
|
|
577 ; (let ((m 0) (p x))
|
|
|
578 ; (while (consp p) (incf m) (pop p))
|
|
|
579 ; (if (<= n 0) p
|
|
|
580 ; (if (< n m) (nthcdr (- m n) x) x)))
|
|
|
581 ; (while (consp (cdr x)) (pop x))
|
|
|
582 ; x))
|
|
|
583
|
|
|
584 ;;; `butlast' is implemented as a C primitive, as of 1998-11
|
|
|
585 ;;; `nbutlast' is implemented as a C primitive, as of 1998-11
|
|
|
586
|
|
|
587 ;(defun butlast (x &optional n)
|
|
|
588 ; "Return a copy of LIST with the last N elements removed."
|
|
|
589 ; (if (and n (<= n 0)) x
|
|
|
590 ; (nbutlast (copy-sequence x) n)))
|
|
|
591
|
|
|
592 ;(defun nbutlast (x &optional n)
|
|
|
593 ; "Modify LIST to remove the last N elements."
|
|
|
594 ; (let ((m (length x)))
|
|
|
595 ; (or n (setq n 1))
|
|
|
596 ; (and (< n m)
|
|
|
597 ; (progn
|
|
|
598 ; (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
|
|
|
599 ; x))))
|
|
|
600
|
|
|
601 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el
|
|
|
602 "Return a new list with specified args as elements, cons'd to last arg.
|
|
|
603 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
|
|
|
604 `(cons A (cons B (cons C D)))'."
|
|
|
605 (cond ((not rest) arg)
|
|
|
606 ((not (cdr rest)) (cons arg (car rest)))
|
|
|
607 (t (let* ((n (length rest))
|
|
|
608 (copy (copy-sequence rest))
|
|
|
609 (last (nthcdr (- n 2) copy)))
|
|
|
610 (setcdr last (car (cdr last)))
|
|
|
611 (cons arg copy)))))
|
|
|
612
|
|
|
613 (defun ldiff (list sublist)
|
|
|
614 "Return a copy of LIST with the tail SUBLIST removed."
|
|
|
615 (let ((res nil))
|
|
|
616 (while (and (consp list) (not (eq list sublist)))
|
|
|
617 (push (pop list) res))
|
|
|
618 (nreverse res)))
|
|
|
619
|
|
|
620 ;;; `copy-list' is implemented as a C primitive, as of 1998-11
|
|
|
621
|
|
|
622 ;(defun copy-list (list)
|
|
|
623 ; "Return a copy of a list, which may be a dotted list.
|
|
|
624 ;The elements of the list are not copied, just the list structure itself."
|
|
|
625 ; (if (consp list)
|
|
|
626 ; (let ((res nil))
|
|
|
627 ; (while (consp list) (push (pop list) res))
|
|
|
628 ; (prog1 (nreverse res) (setcdr res list)))
|
|
|
629 ; (car list)))
|
|
|
630
|
|
|
631 (defun cl-maclisp-member (item list)
|
|
|
632 (while (and list (not (equal item (car list)))) (setq list (cdr list)))
|
|
|
633 list)
|
|
|
634
|
|
|
635 ;;; Define an Emacs 19-compatible `member' for the benefit of Emacs 18 users.
|
|
|
636 (or (and (fboundp 'member) (subrp (symbol-function 'member)))
|
|
|
637 (defalias 'member 'cl-maclisp-member))
|
|
|
638
|
|
|
639 (defalias 'cl-member 'memq) ; for compatibility with old CL package
|
|
|
640 (defalias 'cl-floor 'floor*)
|
|
|
641 (defalias 'cl-ceiling 'ceiling*)
|
|
|
642 (defalias 'cl-truncate 'truncate*)
|
|
|
643 (defalias 'cl-round 'round*)
|
|
|
644 (defalias 'cl-mod 'mod*)
|
|
|
645
|
|
|
646 (defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs
|
|
|
647 "Return ITEM consed onto the front of LIST only if it's not already there.
|
|
|
648 Otherwise, return LIST unmodified.
|
|
|
649 Keywords supported: :test :test-not :key"
|
|
|
650 (cond ((or (equal cl-keys '(:test eq))
|
|
|
651 (and (null cl-keys) (not (numberp cl-item))))
|
|
|
652 (if (memq cl-item cl-list) cl-list (cons cl-item cl-list)))
|
|
|
653 ((or (equal cl-keys '(:test equal)) (null cl-keys))
|
|
|
654 (if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
|
|
|
655 (t (apply 'cl-adjoin cl-item cl-list cl-keys))))
|
|
|
656
|
|
|
657 (defun subst (cl-new cl-old cl-tree &rest cl-keys)
|
|
|
658 "Substitute NEW for OLD everywhere in TREE (non-destructively).
|
|
|
659 Return a copy of TREE with all elements `eql' to OLD replaced by NEW.
|
|
|
660 Keywords supported: :test :test-not :key"
|
|
|
661 (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old))))
|
|
|
662 (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys)
|
|
|
663 (cl-do-subst cl-new cl-old cl-tree)))
|
|
|
664
|
|
|
665 (defun cl-do-subst (cl-new cl-old cl-tree)
|
|
|
666 (cond ((eq cl-tree cl-old) cl-new)
|
|
|
667 ((consp cl-tree)
|
|
|
668 (let ((a (cl-do-subst cl-new cl-old (car cl-tree)))
|
|
|
669 (d (cl-do-subst cl-new cl-old (cdr cl-tree))))
|
|
|
670 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
|
|
|
671 cl-tree (cons a d))))
|
|
|
672 (t cl-tree)))
|
|
|
673
|
|
|
674 (defun acons (a b c)
|
|
|
675 "Return a new alist created by adding (KEY . VALUE) to ALIST."
|
|
|
676 (cons (cons a b) c))
|
|
|
677
|
|
|
678 (defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c))
|
|
|
679
|
|
|
680
|
|
|
681 ;;; Miscellaneous.
|
|
|
682
|
|
|
683 ;; XEmacs change
|
|
|
684 (define-error 'cl-assertion-failed "Assertion failed")
|
|
|
685
|
|
|
686 ;;; This is defined in Emacs 19; define it here for Emacs 18 users.
|
|
|
687 (defun cl-add-hook (hook func &optional append)
|
|
|
688 "Add to hook variable HOOK the function FUNC.
|
|
|
689 FUNC is not added if it already appears on the list stored in HOOK."
|
|
|
690 (let ((old (and (boundp hook) (symbol-value hook))))
|
|
|
691 (and (listp old) (not (eq (car old) 'lambda))
|
|
|
692 (setq old (list old)))
|
|
|
693 (and (not (member func old))
|
|
|
694 (set hook (if append (nconc old (list func)) (cons func old))))))
|
|
|
695 (or (fboundp 'add-hook) (defalias 'add-hook 'cl-add-hook))
|
|
|
696
|
|
|
697 ;; XEmacs change
|
|
|
698 ;(load "cl-defs")
|
|
|
699
|
|
|
700 ;;; Define data for indentation and edebug.
|
|
|
701 (mapcar
|
|
|
702 #'(lambda (entry)
|
|
|
703 (mapcar
|
|
|
704 #'(lambda (func)
|
|
|
705 (put func 'lisp-indent-function (nth 1 entry))
|
|
|
706 (put func 'lisp-indent-hook (nth 1 entry))
|
|
|
707 (or (get func 'edebug-form-spec)
|
|
|
708 (put func 'edebug-form-spec (nth 2 entry))))
|
|
|
709 (car entry)))
|
|
|
710 '(((defun* defmacro*) defun)
|
|
|
711 ((function*) nil
|
|
|
712 (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form)))
|
|
|
713 ((eval-when) 1 (sexp &rest form))
|
|
|
714 ((when unless) 1 (&rest form))
|
|
|
715 ((declare) nil (&rest sexp))
|
|
|
716 ((the) 1 (sexp &rest form))
|
|
|
717 ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form)))
|
|
|
718 ((block return-from) 1 (sexp &rest form))
|
|
|
719 ((return) nil (&optional form))
|
|
|
720 ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form))
|
|
|
721 (form &rest form)
|
|
|
722 &rest form))
|
|
|
723 ((dolist dotimes) 1 ((symbolp form &rest form) &rest form))
|
|
|
724 ((do-symbols) 1 ((symbolp form &optional form form) &rest form))
|
|
|
725 ((do-all-symbols) 1 ((symbolp form &optional form) &rest form))
|
|
|
726 ((psetq setf psetf) nil edebug-setq-form)
|
|
|
727 ((progv) 2 (&rest form))
|
|
|
728 ((flet labels macrolet) 1
|
|
|
729 ((&rest (sexp sexp &rest form)) &rest form))
|
|
|
730 ((symbol-macrolet lexical-let lexical-let*) 1
|
|
|
731 ((&rest &or symbolp (symbolp form)) &rest form))
|
|
|
732 ((multiple-value-bind) 2 ((&rest symbolp) &rest form))
|
|
|
733 ((multiple-value-setq) 1 ((&rest symbolp) &rest form))
|
|
|
734 ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form))
|
|
|
735 ((letf letf*) 1 ((&rest (&rest form)) &rest form))
|
|
|
736 ((callf destructuring-bind) 2 (sexp form &rest form))
|
|
|
737 ((callf2) 3 (sexp form form &rest form))
|
|
|
738 ((loop) defun (&rest &or symbolp form))
|
|
|
739 ((ignore-errors) 0 (&rest form))))
|
|
|
740
|
|
|
741
|
|
|
742 ;;; This goes here so that cl-macs can find it if it loads right now.
|
|
|
743 (provide 'cl-19) ; usage: (require 'cl-19 "cl")
|
|
|
744
|
|
|
745
|
|
|
746 ;;; Things to do after byte-compiler is loaded.
|
|
|
747 ;;; As a side effect, we cause cl-macs to be loaded when compiling, so
|
|
|
748 ;;; that the compiler-macros defined there will be present.
|
|
|
749
|
|
|
750 (defvar cl-hacked-flag nil)
|
|
|
751 (defun cl-hack-byte-compiler ()
|
|
|
752 (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form))
|
|
|
753 (progn
|
|
442
|
754 (when (not (fboundp 'cl-compile-time-init))
|
|
|
755 (load "cl-macs" nil t))
|
|
428
|
756 (cl-compile-time-init) ; in cl-macs.el
|
|
|
757 (setq cl-hacked-flag t))))
|
|
|
758
|
|
|
759 ;;; Try it now in case the compiler has already been loaded.
|
|
|
760 (cl-hack-byte-compiler)
|
|
|
761
|
|
|
762 ;;; Also make a hook in case compiler is loaded after this file.
|
|
|
763 ;;; The compiler doesn't call any hooks when it loads or runs, but
|
|
|
764 ;;; we can take advantage of the fact that emacs-lisp-mode will be
|
|
|
765 ;;; called when the compiler reads in the file to be compiled.
|
|
|
766 ;;; BUG: If the first compilation is `byte-compile' rather than
|
|
|
767 ;;; `byte-compile-file', we lose. Oh, well.
|
|
|
768 (add-hook 'emacs-lisp-mode-hook 'cl-hack-byte-compiler)
|
|
|
769
|
|
|
770
|
|
|
771 ;;; The following ensures that packages which expect the old-style cl.el
|
|
|
772 ;;; will be happy with this one.
|
|
|
773
|
|
|
774 (provide 'cl)
|
|
|
775
|
|
|
776 (provide 'mini-cl) ; for Epoch
|
|
|
777
|
|
|
778 (run-hooks 'cl-load-hook)
|
|
|
779
|
|
|
780 ;;; cl.el ends here
|
