Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 2153:393039450288

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2004-06-26 21:25:23 by james] Synch with Emacs 21.3.
author james
date Sat, 26 Jun 2004 21:25:24 +0000
parents 9c872f33ecbe
children ecf1ebac70d8
comparison
equal deleted inserted replaced
2152:d93fedcbf6be 2153:393039450288
1 ;;; cl-extra.el --- Common Lisp extensions for XEmacs Lisp (part two) 1 ;;; cl-extra.el --- Common Lisp extensions for XEmacs Lisp (part two)
2 2
3 ;; Copyright (C) 1993 Free Software Foundation, Inc. 3 ;; Copyright (C) 1993,2000,2003 Free Software Foundation, Inc.
4 ;; Copyright (C) 2002 Ben Wing. 4 ;; Copyright (C) 2002 Ben Wing.
5 5
6 ;; Author: Dave Gillespie <daveg@synaptics.com> 6 ;; Author: Dave Gillespie <daveg@synaptics.com>
7 ;; Maintainer: XEmacs Development Team 7 ;; Maintainer: XEmacs Development Team
8 ;; Version: 2.02 8 ;; Version: 2.02
23 ;; You should have received a copy of the GNU General Public License 23 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING. If not, write to the Free 24 ;; along with XEmacs; see the file COPYING. If not, write to the Free
25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
26 ;; 02111-1307, USA. 26 ;; 02111-1307, USA.
27 27
28 ;;; Synched up with: FSF 19.34. 28 ;;; Synched up with: FSF 21.3.
29 29
30 ;;; Commentary: 30 ;;; Commentary:
31 31
32 ;; This file is dumped with XEmacs. 32 ;; This file is dumped with XEmacs.
33 33
36 ;; in Emacs Lisp. 36 ;; in Emacs Lisp.
37 ;; 37 ;;
38 ;; This package was written by Dave Gillespie; it is a complete 38 ;; This package was written by Dave Gillespie; it is a complete
39 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. 39 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
40 ;; 40 ;;
41 ;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19.
42 ;;
43 ;; Bug reports, comments, and suggestions are welcome! 41 ;; Bug reports, comments, and suggestions are welcome!
44 42
45 ;; This file contains portions of the Common Lisp extensions 43 ;; This file contains portions of the Common Lisp extensions
46 ;; package which are autoloaded since they are relatively obscure. 44 ;; package which are autoloaded since they are relatively obscure.
47 45
48 ;; See cl.el for Change Log. 46 ;; See cl.el for Change Log.
49 47
50 48
51 ;;; Code: 49 ;;; Code:
50 ;; XEmacs addition
52 (eval-when-compile 51 (eval-when-compile
53 (require 'obsolete)) 52 (require 'obsolete))
54 53
55 (or (memq 'cl-19 features) 54 (or (memq 'cl-19 features)
56 (error "Tried to load `cl-extra' before `cl'!")) 55 (error "Tried to load `cl-extra' before `cl'!"))
57
58
59 ;;; We define these here so that this file can compile without having
60 ;;; loaded the cl.el file already.
61
62 (defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
63 (defmacro cl-pop (place)
64 (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
65
66 (defvar cl-emacs-type)
67 56
68 57
69 ;;; Type coercion. 58 ;;; Type coercion.
70 59
71 (defun coerce (x type) 60 (defun coerce (x type)
75 ((eq type 'vector) (if (vectorp x) x (vconcat x))) 64 ((eq type 'vector) (if (vectorp x) x (vconcat x)))
76 ((eq type 'string) (if (stringp x) x (concat x))) 65 ((eq type 'string) (if (stringp x) x (concat x)))
77 ((eq type 'array) (if (arrayp x) x (vconcat x))) 66 ((eq type 'array) (if (arrayp x) x (vconcat x)))
78 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) 67 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
79 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) 68 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
69 ;; XEmacs addition character <-> integer coercions
80 ((and (eq type 'character) (char-int-p x)) (int-char x)) 70 ((and (eq type 'character) (char-int-p x)) (int-char x))
81 ((and (eq type 'integer) (characterp x)) (char-int x)) 71 ((and (eq type 'integer) (characterp x)) (char-int x))
82 ((eq type 'float) (float x)) 72 ((eq type 'float) (float x))
73 ;; XEmacs addition: enhanced numeric type coercions
83 ((and (featurep 'number-types) 74 ((and (featurep 'number-types)
84 (memq type '(integer ratio bigfloat)) 75 (memq type '(integer ratio bigfloat))
85 (coerce-number x type))) 76 (coerce-number x type)))
77 ;; XEmacs addition: bit-vector coercion
86 ((eq type 'bit-vector) (if (bit-vector-p x) x 78 ((eq type 'bit-vector) (if (bit-vector-p x) x
87 (apply 'bit-vector (append x nil)))) 79 (apply 'bit-vector (append x nil))))
80 ;; XEmacs addition: weak-list coercion
88 ((eq type 'weak-list) 81 ((eq type 'weak-list)
89 (if (weak-list-p x) x 82 (if (weak-list-p x) x
90 (let ((wl (make-weak-list))) 83 (let ((wl (make-weak-list)))
91 (set-weak-list-list wl (if (listp x) x (append x nil))) 84 (set-weak-list-list wl (if (listp x) x (append x nil)))
92 wl))) 85 wl)))
101 This is like `equal', except that it accepts numerically equal 94 This is like `equal', except that it accepts numerically equal
102 numbers of different types (float vs. integer), and also compares 95 numbers of different types (float vs. integer), and also compares
103 strings case-insensitively." 96 strings case-insensitively."
104 (cond ((eq x y) t) 97 (cond ((eq x y) t)
105 ((stringp x) 98 ((stringp x)
106 ;; avoids downcase 99 ;; XEmacs change: avoid downcase
107 (eq t (compare-strings x nil nil y nil nil t))) 100 (eq t (compare-strings x nil nil y nil nil t)))
101 ;; XEmacs addition: compare characters
108 ((characterp x) 102 ((characterp x)
109 (and (characterp y) 103 (and (characterp y)
110 (or (char-equal x y) 104 (or (char-equal x y)
111 (char-equal (downcase x) (downcase y))))) 105 (char-equal (downcase x) (downcase y)))))
112 ((numberp x) 106 ((numberp x)
113 (and (numberp y) (= x y))) 107 (and (numberp y) (= x y)))
114 ((consp x) 108 ((consp x)
115 ;; XEmacs change
116 (while (and (consp x) (consp y) (equalp (car x) (car y))) 109 (while (and (consp x) (consp y) (equalp (car x) (car y)))
117 (cl-pop x) (cl-pop y)) 110 (setq x (cdr x) y (cdr y)))
118 (and (not (consp x)) (equalp x y))) 111 (and (not (consp x)) (equalp x y)))
119 ((vectorp x) 112 ((vectorp x)
120 (and (vectorp y) (= (length x) (length y)) 113 (and (vectorp y) (= (length x) (length y))
121 (let ((i (length x))) 114 (let ((i (length x)))
122 (while (and (>= (setq i (1- i)) 0) 115 (while (and (>= (setq i (1- i)) 0)
142 (if (consp (car cl-p1)) 135 (if (consp (car cl-p1))
143 (prog1 (car (car cl-p1)) 136 (prog1 (car (car cl-p1))
144 (setcar cl-p1 (cdr (car cl-p1)))) 137 (setcar cl-p1 (cdr (car cl-p1))))
145 (aref (car cl-p1) cl-i))) 138 (aref (car cl-p1) cl-i)))
146 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) 139 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
147 (cl-push (apply cl-func cl-args) cl-res) 140 (push (apply cl-func cl-args) cl-res)
148 (setq cl-i (1+ cl-i))) 141 (setq cl-i (1+ cl-i)))
149 (nreverse cl-res)) 142 (nreverse cl-res))
150 (let ((cl-res nil) 143 (let ((cl-res nil)
151 (cl-x (car cl-seqs)) 144 (cl-x (car cl-seqs))
152 (cl-y (nth 1 cl-seqs))) 145 (cl-y (nth 1 cl-seqs)))
153 (let ((cl-n (min (length cl-x) (length cl-y))) 146 (let ((cl-n (min (length cl-x) (length cl-y)))
154 (cl-i -1)) 147 (cl-i -1))
155 (while (< (setq cl-i (1+ cl-i)) cl-n) 148 (while (< (setq cl-i (1+ cl-i)) cl-n)
156 (cl-push (funcall cl-func 149 (push (funcall cl-func
157 (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i)) 150 (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
158 (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i))) 151 (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))
159 cl-res))) 152 cl-res)))
160 (nreverse cl-res)))) 153 (nreverse cl-res))))
161 154
162 (defun map (cl-type cl-func cl-seq &rest cl-rest) 155 (defun map (cl-type cl-func cl-seq &rest cl-rest)
163 "Map a function across one or more sequences, returning a sequence. 156 "Map a function across one or more sequences, returning a sequence.
173 (if cl-rest 166 (if cl-rest
174 (let ((cl-res nil) 167 (let ((cl-res nil)
175 (cl-args (cons cl-list (copy-sequence cl-rest))) 168 (cl-args (cons cl-list (copy-sequence cl-rest)))
176 cl-p) 169 cl-p)
177 (while (not (memq nil cl-args)) 170 (while (not (memq nil cl-args))
178 (cl-push (apply cl-func cl-args) cl-res) 171 (push (apply cl-func cl-args) cl-res)
179 (setq cl-p cl-args) 172 (setq cl-p cl-args)
180 (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) ))) 173 (while cl-p (setcar cl-p (cdr (pop cl-p)) )))
181 (nreverse cl-res)) 174 (nreverse cl-res))
182 (let ((cl-res nil)) 175 (let ((cl-res nil))
183 (while cl-list 176 (while cl-list
184 (cl-push (funcall cl-func cl-list) cl-res) 177 (push (funcall cl-func cl-list) cl-res)
185 (setq cl-list (cdr cl-list))) 178 (setq cl-list (cdr cl-list)))
186 (nreverse cl-res)))) 179 (nreverse cl-res))))
187 180
188 181 ;; XEmacs change: in Emacs, this function is named cl-mapc.
189 (defun mapc (cl-func cl-seq &rest cl-rest) 182 (defun mapc (cl-func cl-seq &rest cl-rest)
190 "Like `mapcar', but does not accumulate values returned by the function." 183 "Like `mapcar', but does not accumulate values returned by the function."
191 (if cl-rest 184 (if cl-rest
192 (apply 'map nil cl-func cl-seq cl-rest) 185 (apply 'map nil cl-func cl-seq cl-rest)
193 ;; XEmacs change: in the simplest case we call mapc-internal, 186 ;; XEmacs change: in the simplest case we call mapc-internal,
194 ;; which really doesn't accumulate any results. 187 ;; which really doesn't accumulate any results.
195 (mapc-internal cl-func cl-seq)) 188 (mapc-internal cl-func cl-seq))
196 cl-seq) 189 cl-seq)
190
191 ;; XEmacs addition: FSF compatibility
192 (defalias 'cl-mapc 'mapc)
197 193
198 (defun mapl (cl-func cl-list &rest cl-rest) 194 (defun mapl (cl-func cl-list &rest cl-rest)
199 "Like `maplist', but does not accumulate values returned by the function." 195 "Like `maplist', but does not accumulate values returned by the function."
200 (if cl-rest 196 (if cl-rest
201 (apply 'maplist cl-func cl-list cl-rest) 197 (apply 'maplist cl-func cl-list cl-rest)
220 (function (lambda (&rest cl-x) 216 (function (lambda (&rest cl-x)
221 (let ((cl-res (apply cl-pred cl-x))) 217 (let ((cl-res (apply cl-pred cl-x)))
222 (if cl-res (throw 'cl-some cl-res))))) 218 (if cl-res (throw 'cl-some cl-res)))))
223 cl-seq cl-rest) nil) 219 cl-seq cl-rest) nil)
224 (let ((cl-x nil)) 220 (let ((cl-x nil))
225 (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq)))))) 221 (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
226 cl-x))) 222 cl-x)))
227 223
228 (defun every (cl-pred cl-seq &rest cl-rest) 224 (defun every (cl-pred cl-seq &rest cl-rest)
229 "Return true if PREDICATE is true of every element of SEQ or SEQs." 225 "Return true if PREDICATE is true of every element of SEQ or SEQs."
230 (if (or cl-rest (nlistp cl-seq)) 226 (if (or cl-rest (nlistp cl-seq))
244 (defun notevery (cl-pred cl-seq &rest cl-rest) 240 (defun notevery (cl-pred cl-seq &rest cl-rest)
245 "Return true if PREDICATE is false of some element of SEQ or SEQs." 241 "Return true if PREDICATE is false of some element of SEQ or SEQs."
246 (not (apply 'every cl-pred cl-seq cl-rest))) 242 (not (apply 'every cl-pred cl-seq cl-rest)))
247 243
248 ;;; Support for `loop'. 244 ;;; Support for `loop'.
249 (defun cl-map-keymap (cl-func cl-map) 245 (defalias 'cl-map-keymap 'map-keymap)
250 (while (symbolp cl-map) (setq cl-map (symbol-function cl-map)))
251 (if (eq cl-emacs-type 'lucid) (funcall 'map-keymap cl-func cl-map)
252 (if (listp cl-map)
253 (let ((cl-p cl-map))
254 (while (consp (setq cl-p (cdr cl-p)))
255 (cond ((consp (car cl-p))
256 (funcall cl-func (car (car cl-p)) (cdr (car cl-p))))
257 ((vectorp (car cl-p))
258 (cl-map-keymap cl-func (car cl-p)))
259 ((eq (car cl-p) 'keymap)
260 (setq cl-p nil)))))
261 (let ((cl-i -1))
262 (while (< (setq cl-i (1+ cl-i)) (length cl-map))
263 (if (aref cl-map cl-i)
264 (funcall cl-func cl-i (aref cl-map cl-i))))))))
265 246
266 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) 247 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
267 (or cl-base 248 (or cl-base
268 (setq cl-base (copy-sequence (if (eq cl-emacs-type 18) "0" [0])))) 249 (setq cl-base (copy-sequence [0])))
269 (cl-map-keymap 250 (map-keymap
270 (function 251 (function
271 (lambda (cl-key cl-bind) 252 (lambda (cl-key cl-bind)
272 (aset cl-base (1- (length cl-base)) cl-key) 253 (aset cl-base (1- (length cl-base)) cl-key)
273 (if (keymapp cl-bind) 254 (if (keymapp cl-bind)
274 (cl-map-keymap-recursively 255 (cl-map-keymap-recursively
275 cl-func-rec cl-bind 256 cl-func-rec cl-bind
276 (funcall (if (eq cl-emacs-type 18) 'concat 'vconcat) 257 (vconcat cl-base (list 0)))
277 cl-base (list 0)))
278 (funcall cl-func-rec cl-base cl-bind)))) 258 (funcall cl-func-rec cl-base cl-bind))))
279 cl-map)) 259 cl-map))
280 260
281 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) 261 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
282 (or cl-what (setq cl-what (current-buffer))) 262 (or cl-what (setq cl-what (current-buffer)))
283 (if (bufferp cl-what) 263 (if (bufferp cl-what)
284 (let (cl-mark cl-mark2 (cl-next t) cl-next2) 264 (let (cl-mark cl-mark2 (cl-next t) cl-next2)
285 (save-excursion 265 (with-current-buffer cl-what
286 (set-buffer cl-what)
287 (setq cl-mark (copy-marker (or cl-start (point-min)))) 266 (setq cl-mark (copy-marker (or cl-start (point-min))))
288 (setq cl-mark2 (and cl-end (copy-marker cl-end)))) 267 (setq cl-mark2 (and cl-end (copy-marker cl-end))))
289 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) 268 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
290 (setq cl-next (and-fboundp 'next-property-change 269 (setq cl-next (if cl-prop (next-single-property-change
291 (if cl-prop (next-single-property-change 270 cl-mark cl-prop cl-what)
292 cl-mark cl-prop cl-what) 271 (next-property-change cl-mark cl-what))
293 (next-property-change cl-mark cl-what))) 272 cl-next2 (or cl-next (with-current-buffer cl-what
294 cl-next2 (or cl-next (save-excursion 273 (point-max))))
295 (set-buffer cl-what) (point-max))))
296 (funcall cl-func (prog1 (marker-position cl-mark) 274 (funcall cl-func (prog1 (marker-position cl-mark)
297 (set-marker cl-mark cl-next2)) 275 (set-marker cl-mark cl-next2))
298 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) 276 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
299 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) 277 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
300 (or cl-start (setq cl-start 0)) 278 (or cl-start (setq cl-start 0))
301 (or cl-end (setq cl-end (length cl-what))) 279 (or cl-end (setq cl-end (length cl-what)))
302 (while (< cl-start cl-end) 280 (while (< cl-start cl-end)
303 (let ((cl-next (or (and-fboundp 'next-property-change 281 (let ((cl-next (or (if cl-prop (next-single-property-change
304 (if cl-prop (next-single-property-change 282 cl-start cl-prop cl-what)
305 cl-start cl-prop cl-what) 283 (next-property-change cl-start cl-what))
306 (next-property-change cl-start cl-what)))
307 cl-end))) 284 cl-end)))
308 (funcall cl-func cl-start (min cl-next cl-end)) 285 (funcall cl-func cl-start (min cl-next cl-end))
309 (setq cl-start cl-next))))) 286 (setq cl-start cl-next)))))
310 287
311 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) 288 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
314 (if-fboundp 'overlay-lists 291 (if-fboundp 'overlay-lists
315 292
316 ;; This is the preferred algorithm, though overlay-lists is 293 ;; This is the preferred algorithm, though overlay-lists is
317 ;; undocumented. 294 ;; undocumented.
318 (let (cl-ovl) 295 (let (cl-ovl)
319 (save-excursion 296 (with-current-buffer cl-buffer
320 (set-buffer cl-buffer)
321 (setq cl-ovl (overlay-lists)) 297 (setq cl-ovl (overlay-lists))
322 (if cl-start (setq cl-start (copy-marker cl-start))) 298 (if cl-start (setq cl-start (copy-marker cl-start)))
323 (if cl-end (setq cl-end (copy-marker cl-end)))) 299 (if cl-end (setq cl-end (copy-marker cl-end))))
324 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) 300 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
325 (while (and cl-ovl 301 (while (and cl-ovl
331 (setq cl-ovl (cdr cl-ovl))) 307 (setq cl-ovl (cdr cl-ovl)))
332 (if cl-start (set-marker cl-start nil)) 308 (if cl-start (set-marker cl-start nil))
333 (if cl-end (set-marker cl-end nil))) 309 (if cl-end (set-marker cl-end nil)))
334 310
335 ;; This alternate algorithm fails to find zero-length overlays. 311 ;; This alternate algorithm fails to find zero-length overlays.
336 (let ((cl-mark (save-excursion (set-buffer cl-buffer) 312 (let ((cl-mark (with-current-buffer cl-buffer
337 (copy-marker (or cl-start (point-min))))) 313 (copy-marker (or cl-start (point-min)))))
338 (cl-mark2 (and cl-end (save-excursion (set-buffer cl-buffer) 314 (cl-mark2 (and cl-end (with-current-buffer cl-buffer
339 (copy-marker cl-end)))) 315 (copy-marker cl-end))))
340 cl-pos cl-ovl) 316 cl-pos cl-ovl)
341 (while (save-excursion 317 (while (save-excursion
342 (and (setq cl-pos (marker-position cl-mark)) 318 (and (setq cl-pos (marker-position cl-mark))
343 (< cl-pos (or cl-mark2 (point-max))) 319 (< cl-pos (or cl-mark2 (point-max)))
344 (progn 320 (progn
361 337
362 ;;; Support for `progv'. 338 ;;; Support for `progv'.
363 (defvar cl-progv-save) 339 (defvar cl-progv-save)
364 (defun cl-progv-before (syms values) 340 (defun cl-progv-before (syms values)
365 (while syms 341 (while syms
366 (cl-push (if (boundp (car syms)) 342 (push (if (boundp (car syms))
367 (cons (car syms) (symbol-value (car syms))) 343 (cons (car syms) (symbol-value (car syms)))
368 (car syms)) cl-progv-save) 344 (car syms)) cl-progv-save)
369 (if values 345 (if values
370 (set (cl-pop syms) (cl-pop values)) 346 (set (pop syms) (pop values))
371 (makunbound (cl-pop syms))))) 347 (makunbound (pop syms)))))
372 348
373 (defun cl-progv-after () 349 (defun cl-progv-after ()
374 (while cl-progv-save 350 (while cl-progv-save
375 (if (consp (car cl-progv-save)) 351 (if (consp (car cl-progv-save))
376 (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) 352 (set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
377 (makunbound (car cl-progv-save))) 353 (makunbound (car cl-progv-save)))
378 (cl-pop cl-progv-save))) 354 (pop cl-progv-save)))
379 355
380 356
381 ;;; Numbers. 357 ;;; Numbers.
382 358
383 (defun gcd (&rest args) 359 (defun gcd (&rest args)
384 "Return the greatest common divisor of the arguments." 360 "Return the greatest common divisor of the arguments."
385 (let ((a (abs (or (cl-pop args) 0)))) 361 (let ((a (abs (or (pop args) 0))))
386 (while args 362 (while args
387 (let ((b (abs (cl-pop args)))) 363 (let ((b (abs (pop args))))
388 (while (> b 0) (setq b (% a (setq a b)))))) 364 (while (> b 0) (setq b (% a (setq a b))))))
389 a)) 365 a))
390 366
391 (defun lcm (&rest args) 367 (defun lcm (&rest args)
392 "Return the least common multiple of the arguments." 368 "Return the least common multiple of the arguments."
393 (if (memq 0 args) 369 (if (memq 0 args)
394 0 370 0
395 (let ((a (abs (or (cl-pop args) 1)))) 371 (let ((a (abs (or (pop args) 1))))
396 (while args 372 (while args
397 (let ((b (abs (cl-pop args)))) 373 (let ((b (abs (pop args))))
398 (setq a (* (/ a (gcd a b)) b)))) 374 (setq a (* (/ a (gcd a b)) b))))
399 a))) 375 a)))
400 376
401 (defun isqrt (a) 377 (defun isqrt (a)
402 "Return the integer square root of the argument." 378 "Return the integer square root of the argument."
408 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) 384 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
409 (setq g g2)) 385 (setq g g2))
410 g) 386 g)
411 (if (eq a 0) 0 (signal 'arith-error nil)))) 387 (if (eq a 0) 0 (signal 'arith-error nil))))
412 388
389 ;; XEmacs addition
413 (defun cl-expt (x y) 390 (defun cl-expt (x y)
414 "Return X raised to the power of Y. Works only for integer arguments." 391 "Return X raised to the power of Y. Works only for integer arguments."
415 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) 392 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0))
416 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) 393 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2)))))
417 (or (and (fboundp 'expt) (subrp (symbol-function 'expt))) 394 (or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
574 ; (cond ((listp seq) 551 ; (cond ((listp seq)
575 ; (if (> start 0) (setq seq (nthcdr start seq))) 552 ; (if (> start 0) (setq seq (nthcdr start seq)))
576 ; (if end 553 ; (if end
577 ; (let ((res nil)) 554 ; (let ((res nil))
578 ; (while (>= (setq end (1- end)) start) 555 ; (while (>= (setq end (1- end)) start)
579 ; (cl-push (cl-pop seq) res)) 556 ; (push (pop seq) res))
580 ; (nreverse res)) 557 ; (nreverse res))
581 ; (copy-sequence seq))) 558 ; (copy-sequence seq)))
582 ; (t 559 ; (t
583 ; (or end (setq end (or len (length seq)))) 560 ; (or end (setq end (or len (length seq))))
584 ; (let ((res (make-vector (max (- end start) 0) nil)) 561 ; (let ((res (make-vector (max (- end start) 0) nil))
588 ; (setq i (1+ i) start (1+ start))) 565 ; (setq i (1+ i) start (1+ start)))
589 ; res)))))) 566 ; res))))))
590 567
591 (defun concatenate (type &rest seqs) 568 (defun concatenate (type &rest seqs)
592 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." 569 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES."
570 ;; XEmacs change: use case instead of cond for clarity
593 (case type 571 (case type
594 (vector (apply 'vconcat seqs)) 572 (vector (apply 'vconcat seqs))
595 (string (apply 'concat seqs)) 573 (string (apply 'concat seqs))
596 (list (apply 'append (append seqs '(nil)))) 574 (list (apply 'append (append seqs '(nil))))
597 (t (error "Not a sequence type name: %s" type)))) 575 (t (error "Not a sequence type name: %s" type))))
617 "Return true if SUBLIST is a tail of LIST." 595 "Return true if SUBLIST is a tail of LIST."
618 (while (and (consp list) (not (eq sublist list))) 596 (while (and (consp list) (not (eq sublist list)))
619 (setq list (cdr list))) 597 (setq list (cdr list)))
620 (if (numberp sublist) (equal sublist list) (eq sublist list))) 598 (if (numberp sublist) (equal sublist list) (eq sublist list)))
621 599
622 (defun cl-copy-tree (tree &optional vecp) 600 (defalias 'cl-copy-tree 'copy-tree)
623 "Make a copy of TREE.
624 If TREE is a cons cell, this recursively copies both its car and its cdr.
625 Contrast to copy-sequence, which copies only along the cdrs. With second
626 argument VECP, this copies vectors as well as conses."
627 (if (consp tree)
628 (let ((p (setq tree (copy-list tree))))
629 (while (consp p)
630 (if (or (consp (car p)) (and vecp (vectorp (car p))))
631 (setcar p (cl-copy-tree (car p) vecp)))
632 (or (listp (cdr p)) (setcdr p (cl-copy-tree (cdr p) vecp)))
633 (cl-pop p)))
634 (if (and vecp (vectorp tree))
635 (let ((i (length (setq tree (copy-sequence tree)))))
636 (while (>= (setq i (1- i)) 0)
637 (aset tree i (cl-copy-tree (aref tree i) vecp))))))
638 tree)
639 (or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree)))
640 (defalias 'copy-tree 'cl-copy-tree))
641 601
642 602
643 ;;; Property lists. 603 ;;; Property lists.
644 604
645 ;; XEmacs: our `get' groks DEFAULT. 605 ;; XEmacs: our `get' groks DEFAULT.
653 613
654 (defun cl-do-remf (plist tag) 614 (defun cl-do-remf (plist tag)
655 (let ((p (cdr plist))) 615 (let ((p (cdr plist)))
656 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) 616 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
657 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) 617 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
618
619 ;; XEmacs change: we have a builtin remprop
620 (defalias 'cl-remprop 'remprop)
621
622
658 623
659 ;;; Hash tables. 624 ;;; Hash tables.
660 625
661 ;; The `regular' Common Lisp hash-table stuff has been moved into C. 626 ;; The `regular' Common Lisp hash-table stuff has been moved into C.
662 ;; Only backward compatibility stuff remains here. 627 ;; Only backward compatibility stuff remains here.
694 (defalias 'cl-gethash 'gethash) 659 (defalias 'cl-gethash 'gethash)
695 (defalias 'cl-puthash 'puthash) 660 (defalias 'cl-puthash 'puthash)
696 (defalias 'cl-remhash 'remhash) 661 (defalias 'cl-remhash 'remhash)
697 (defalias 'cl-clrhash 'clrhash) 662 (defalias 'cl-clrhash 'clrhash)
698 (defalias 'cl-maphash 'maphash) 663 (defalias 'cl-maphash 'maphash)
664 ;; These three actually didn't exist in Emacs-20.
665 (defalias 'cl-make-hash-table 'make-hash-table)
666 (defalias 'cl-hash-table-p 'hash-table-p)
667 (defalias 'cl-hash-table-count 'hash-table-count)
699 668
700 ;;; Some debugging aids. 669 ;;; Some debugging aids.
701 670
702 (defun cl-prettyprint (form) 671 (defun cl-prettyprint (form)
703 "Insert a pretty-printed rendition of a Lisp FORM in current buffer." 672 "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
715 684
716 (defun cl-do-prettyprint () 685 (defun cl-do-prettyprint ()
717 (skip-chars-forward " ") 686 (skip-chars-forward " ")
718 (if (looking-at "(") 687 (if (looking-at "(")
719 (let ((skip (or (looking-at "((") 688 (let ((skip (or (looking-at "((")
689 ;; XEmacs: be selective about trailing stuff after prog
720 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]") 690 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]")
721 (looking-at "(unwind-protect ") 691 (looking-at "(unwind-protect ")
722 (looking-at "(function (") 692 (looking-at "(function (")
723 (looking-at "(cl-block-wrapper "))) 693 (looking-at "(cl-block-wrapper ")))
724 (two (or (looking-at "(defun ") (looking-at "(defmacro "))) 694 (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
754 ((memq (car form) '(let let*)) 724 ((memq (car form) '(let let*))
755 (if (null (nth 1 form)) 725 (if (null (nth 1 form))
756 (cl-macroexpand-all (cons 'progn (cddr form)) env) 726 (cl-macroexpand-all (cons 'progn (cddr form)) env)
757 (let ((letf nil) (res nil) (lets (cadr form))) 727 (let ((letf nil) (res nil) (lets (cadr form)))
758 (while lets 728 (while lets
759 (cl-push (if (consp (car lets)) 729 (push (if (consp (car lets))
760 (let ((exp (cl-macroexpand-all (caar lets) env))) 730 (let ((exp (cl-macroexpand-all (caar lets) env)))
761 (or (symbolp exp) (setq letf t)) 731 (or (symbolp exp) (setq letf t))
762 (cons exp (cl-macroexpand-body (cdar lets) env))) 732 (cons exp (cl-macroexpand-body (cdar lets) env)))
763 (let ((exp (cl-macroexpand-all (car lets) env))) 733 (let ((exp (cl-macroexpand-all (car lets) env)))
764 (if (symbolp exp) exp 734 (if (symbolp exp) exp
783 (cl-expr-contains-any body cl-closure-vars)) 753 (cl-expr-contains-any body cl-closure-vars))
784 (let* ((new (mapcar 'gensym cl-closure-vars)) 754 (let* ((new (mapcar 'gensym cl-closure-vars))
785 (sub (pairlis cl-closure-vars new)) (decls nil)) 755 (sub (pairlis cl-closure-vars new)) (decls nil))
786 (while (or (stringp (car body)) 756 (while (or (stringp (car body))
787 (eq (car-safe (car body)) 'interactive)) 757 (eq (car-safe (car body)) 'interactive))
788 (cl-push (list 'quote (cl-pop body)) decls)) 758 (push (list 'quote (pop body)) decls))
789 (put (car (last cl-closure-vars)) 'used t) 759 (put (car (last cl-closure-vars)) 'used t)
790 (append 760 (append
791 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) 761 (list 'list '(quote lambda) '(quote (&rest --cl-rest--)))
792 (sublis sub (nreverse decls)) 762 (sublis sub (nreverse decls))
793 (list 763 (list
794 (list* 'list '(quote apply) 764 (list* 'list '(quote apply)
765 ;; XEmacs: put a quote before the function
795 (list 'list '(quote quote) 766 (list 'list '(quote quote)
796 (list 'function 767 (list 'function
797 (list* 'lambda 768 (list* 'lambda
798 (append new (cadadr form)) 769 (append new (cadadr form))
799 (sublis sub body)))) 770 (sublis sub body))))
802 (list 'list '(quote quote) x))) 773 (list 'list '(quote quote) x)))
803 cl-closure-vars) 774 cl-closure-vars)
804 '((quote --cl-rest--))))))) 775 '((quote --cl-rest--)))))))
805 (list (car form) (list* 'lambda (cadadr form) body)))) 776 (list (car form) (list* 'lambda (cadadr form) body))))
806 (let ((found (assq (cadr form) env))) 777 (let ((found (assq (cadr form) env)))
778 ;; XEmacs: cadr/caddr operate on nil without errors
807 (if (eq (cadr (caddr found)) 'cl-labels-args) 779 (if (eq (cadr (caddr found)) 'cl-labels-args)
808 (cl-macroexpand-all (cadr (caddr (cadddr found))) env) 780 (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
809 form)))) 781 form))))
810 ((memq (car form) '(defun defmacro)) 782 ((memq (car form) '(defun defmacro))
811 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) 783 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
832 804
833 805
834 806
835 (run-hooks 'cl-extra-load-hook) 807 (run-hooks 'cl-extra-load-hook)
836 808
809 ;; XEmacs addition
837 (provide 'cl-extra) 810 (provide 'cl-extra)
838 811
812 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
839 ;;; cl-extra.el ends here 813 ;;; cl-extra.el ends here