Mercurial > emacs
comparison lisp/emacs-lisp/cl-extra.el @ 90185:5b029ff3b08d
Revision: miles@gnu.org--gnu-2005/emacs--unicode--0--patch-55
Merge from emacs--cvs-trunk--0
Patches applied:
* emacs--cvs-trunk--0 (patch 320-323)
- Update from CVS
author | Miles Bader <miles@gnu.org> |
---|---|
date | Thu, 26 May 2005 05:42:19 +0000 |
parents | f042e7c0fe20 30ac735c84d8 |
children | f9a65d7ebd29 |
comparison
equal
deleted
inserted
replaced
90184:9e5e2f01c7ab | 90185:5b029ff3b08d |
---|---|
44 | 44 |
45 ;;; Type coercion. | 45 ;;; Type coercion. |
46 | 46 |
47 (defun coerce (x type) | 47 (defun coerce (x type) |
48 "Coerce OBJECT to type TYPE. | 48 "Coerce OBJECT to type TYPE. |
49 TYPE is a Common Lisp type specifier." | 49 TYPE is a Common Lisp type specifier. |
50 \n(fn OBJECT TYPE)" | |
50 (cond ((eq type 'list) (if (listp x) x (append x nil))) | 51 (cond ((eq type 'list) (if (listp x) x (append x nil))) |
51 ((eq type 'vector) (if (vectorp x) x (vconcat x))) | 52 ((eq type 'vector) (if (vectorp x) x (vconcat x))) |
52 ((eq type 'string) (if (stringp x) x (concat x))) | 53 ((eq type 'string) (if (stringp x) x (concat x))) |
53 ((eq type 'array) (if (arrayp x) x (vconcat x))) | 54 ((eq type 'array) (if (arrayp x) x (vconcat x))) |
54 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) | 55 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) |
118 (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) | 119 (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) |
119 cl-res))) | 120 cl-res))) |
120 (nreverse cl-res)))) | 121 (nreverse cl-res)))) |
121 | 122 |
122 (defun map (cl-type cl-func cl-seq &rest cl-rest) | 123 (defun map (cl-type cl-func cl-seq &rest cl-rest) |
123 "Map a function across one or more sequences, returning a sequence. | 124 "Map a FUNCTION across one or more SEQUENCEs, returning a sequence. |
124 TYPE is the sequence type to return, FUNC is the function, and SEQS | 125 TYPE is the sequence type to return. |
125 are the argument sequences." | 126 \n(fn TYPE FUNCTION SEQUENCE...)" |
126 (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) | 127 (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) |
127 (and cl-type (coerce cl-res cl-type)))) | 128 (and cl-type (coerce cl-res cl-type)))) |
128 | 129 |
129 (defun maplist (cl-func cl-list &rest cl-rest) | 130 (defun maplist (cl-func cl-list &rest cl-rest) |
130 "Map FUNC to each sublist of LIST or LISTS. | 131 "Map FUNCTION to each sublist of LIST or LISTs. |
131 Like `mapcar', except applies to lists and their cdr's rather than to | 132 Like `mapcar', except applies to lists and their cdr's rather than to |
132 the elements themselves." | 133 the elements themselves. |
134 \n(fn FUNCTION LIST...)" | |
133 (if cl-rest | 135 (if cl-rest |
134 (let ((cl-res nil) | 136 (let ((cl-res nil) |
135 (cl-args (cons cl-list (copy-sequence cl-rest))) | 137 (cl-args (cons cl-list (copy-sequence cl-rest))) |
136 cl-p) | 138 cl-p) |
137 (while (not (memq nil cl-args)) | 139 (while (not (memq nil cl-args)) |
144 (push (funcall cl-func cl-list) cl-res) | 146 (push (funcall cl-func cl-list) cl-res) |
145 (setq cl-list (cdr cl-list))) | 147 (setq cl-list (cdr cl-list))) |
146 (nreverse cl-res)))) | 148 (nreverse cl-res)))) |
147 | 149 |
148 (defun cl-mapc (cl-func cl-seq &rest cl-rest) | 150 (defun cl-mapc (cl-func cl-seq &rest cl-rest) |
149 "Like `mapcar', but does not accumulate values returned by the function." | 151 "Like `mapcar', but does not accumulate values returned by the function. |
152 \n(fn FUNCTION SEQUENCE...)" | |
150 (if cl-rest | 153 (if cl-rest |
151 (progn (apply 'map nil cl-func cl-seq cl-rest) | 154 (progn (apply 'map nil cl-func cl-seq cl-rest) |
152 cl-seq) | 155 cl-seq) |
153 (mapc cl-func cl-seq))) | 156 (mapc cl-func cl-seq))) |
154 | 157 |
155 (defun mapl (cl-func cl-list &rest cl-rest) | 158 (defun mapl (cl-func cl-list &rest cl-rest) |
156 "Like `maplist', but does not accumulate values returned by the function." | 159 "Like `maplist', but does not accumulate values returned by the function. |
160 \n(fn FUNCTION LIST...)" | |
157 (if cl-rest | 161 (if cl-rest |
158 (apply 'maplist cl-func cl-list cl-rest) | 162 (apply 'maplist cl-func cl-list cl-rest) |
159 (let ((cl-p cl-list)) | 163 (let ((cl-p cl-list)) |
160 (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) | 164 (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) |
161 cl-list) | 165 cl-list) |
162 | 166 |
163 (defun mapcan (cl-func cl-seq &rest cl-rest) | 167 (defun mapcan (cl-func cl-seq &rest cl-rest) |
164 "Like `mapcar', but nconc's together the values returned by the function." | 168 "Like `mapcar', but nconc's together the values returned by the function. |
169 \n(fn FUNCTION SEQUENCE...)" | |
165 (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) | 170 (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) |
166 | 171 |
167 (defun mapcon (cl-func cl-list &rest cl-rest) | 172 (defun mapcon (cl-func cl-list &rest cl-rest) |
168 "Like `maplist', but nconc's together the values returned by the function." | 173 "Like `maplist', but nconc's together the values returned by the function. |
174 \n(fn FUNCTION LIST...)" | |
169 (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) | 175 (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) |
170 | 176 |
171 (defun some (cl-pred cl-seq &rest cl-rest) | 177 (defun some (cl-pred cl-seq &rest cl-rest) |
172 "Return true if PREDICATE is true of any element of SEQ or SEQs. | 178 "Return true if PREDICATE is true of any element of SEQ or SEQs. |
173 If so, return the true (non-nil) value returned by PREDICATE." | 179 If so, return the true (non-nil) value returned by PREDICATE. |
180 \n(fn PREDICATE SEQ...)" | |
174 (if (or cl-rest (nlistp cl-seq)) | 181 (if (or cl-rest (nlistp cl-seq)) |
175 (catch 'cl-some | 182 (catch 'cl-some |
176 (apply 'map nil | 183 (apply 'map nil |
177 (function (lambda (&rest cl-x) | 184 (function (lambda (&rest cl-x) |
178 (let ((cl-res (apply cl-pred cl-x))) | 185 (let ((cl-res (apply cl-pred cl-x))) |
181 (let ((cl-x nil)) | 188 (let ((cl-x nil)) |
182 (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) | 189 (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) |
183 cl-x))) | 190 cl-x))) |
184 | 191 |
185 (defun every (cl-pred cl-seq &rest cl-rest) | 192 (defun every (cl-pred cl-seq &rest cl-rest) |
186 "Return true if PREDICATE is true of every element of SEQ or SEQs." | 193 "Return true if PREDICATE is true of every element of SEQ or SEQs. |
194 \n(fn PREDICATE SEQ...)" | |
187 (if (or cl-rest (nlistp cl-seq)) | 195 (if (or cl-rest (nlistp cl-seq)) |
188 (catch 'cl-every | 196 (catch 'cl-every |
189 (apply 'map nil | 197 (apply 'map nil |
190 (function (lambda (&rest cl-x) | 198 (function (lambda (&rest cl-x) |
191 (or (apply cl-pred cl-x) (throw 'cl-every nil)))) | 199 (or (apply cl-pred cl-x) (throw 'cl-every nil)))) |
193 (while (and cl-seq (funcall cl-pred (car cl-seq))) | 201 (while (and cl-seq (funcall cl-pred (car cl-seq))) |
194 (setq cl-seq (cdr cl-seq))) | 202 (setq cl-seq (cdr cl-seq))) |
195 (null cl-seq))) | 203 (null cl-seq))) |
196 | 204 |
197 (defun notany (cl-pred cl-seq &rest cl-rest) | 205 (defun notany (cl-pred cl-seq &rest cl-rest) |
198 "Return true if PREDICATE is false of every element of SEQ or SEQs." | 206 "Return true if PREDICATE is false of every element of SEQ or SEQs. |
207 \n(fn PREDICATE SEQ...)" | |
199 (not (apply 'some cl-pred cl-seq cl-rest))) | 208 (not (apply 'some cl-pred cl-seq cl-rest))) |
200 | 209 |
201 (defun notevery (cl-pred cl-seq &rest cl-rest) | 210 (defun notevery (cl-pred cl-seq &rest cl-rest) |
202 "Return true if PREDICATE is false of some element of SEQ or SEQs." | 211 "Return true if PREDICATE is false of some element of SEQ or SEQs. |
212 \n(fn PREDICATE SEQ...)" | |
203 (not (apply 'every cl-pred cl-seq cl-rest))) | 213 (not (apply 'every cl-pred cl-seq cl-rest))) |
204 | 214 |
205 ;;; Support for `loop'. | 215 ;;; Support for `loop'. |
206 (defalias 'cl-map-keymap 'map-keymap) | 216 (defalias 'cl-map-keymap 'map-keymap) |
207 | 217 |
330 (while args | 340 (while args |
331 (let ((b (abs (pop args)))) | 341 (let ((b (abs (pop args)))) |
332 (setq a (* (/ a (gcd a b)) b)))) | 342 (setq a (* (/ a (gcd a b)) b)))) |
333 a))) | 343 a))) |
334 | 344 |
335 (defun isqrt (a) | 345 (defun isqrt (x) |
336 "Return the integer square root of the argument." | 346 "Return the integer square root of the argument." |
337 (if (and (integerp a) (> a 0)) | 347 (if (and (integerp x) (> x 0)) |
338 (let ((g (cond ((<= a 100) 10) ((<= a 10000) 100) | 348 (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100) |
339 ((<= a 1000000) 1000) (t a))) | 349 ((<= x 1000000) 1000) (t x))) |
340 g2) | 350 g2) |
341 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | 351 (while (< (setq g2 (/ (+ g (/ x g)) 2)) g) |
342 (setq g g2)) | 352 (setq g g2)) |
343 g) | 353 g) |
344 (if (eq a 0) 0 (signal 'arith-error nil)))) | 354 (if (eq x 0) 0 (signal 'arith-error nil)))) |
345 | 355 |
346 (defun floor* (x &optional y) | 356 (defun floor* (x &optional y) |
347 "Return a list of the floor of X and the fractional part of X. | 357 "Return a list of the floor of X and the fractional part of X. |
348 With two arguments, return floor and remainder of their quotient." | 358 With two arguments, return floor and remainder of their quotient." |
349 (let ((q (floor x y))) | 359 (let ((q (floor x y))) |
386 | 396 |
387 (defun rem* (x y) | 397 (defun rem* (x y) |
388 "The remainder of X divided by Y, with the same sign as X." | 398 "The remainder of X divided by Y, with the same sign as X." |
389 (nth 1 (truncate* x y))) | 399 (nth 1 (truncate* x y))) |
390 | 400 |
391 (defun signum (a) | 401 (defun signum (x) |
392 "Return 1 if A is positive, -1 if negative, 0 if zero." | 402 "Return 1 if X is positive, -1 if negative, 0 if zero." |
393 (cond ((> a 0) 1) ((< a 0) -1) (t 0))) | 403 (cond ((> x 0) 1) ((< x 0) -1) (t 0))) |
394 | 404 |
395 | 405 |
396 ;; Random numbers. | 406 ;; Random numbers. |
397 | 407 |
398 (defvar *random-state*) | 408 (defvar *random-state*) |
512 (aset res i (aref seq start)) | 522 (aset res i (aref seq start)) |
513 (setq i (1+ i) start (1+ start))) | 523 (setq i (1+ i) start (1+ start))) |
514 res)))))) | 524 res)))))) |
515 | 525 |
516 (defun concatenate (type &rest seqs) | 526 (defun concatenate (type &rest seqs) |
517 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." | 527 "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. |
528 \n(fn TYPE SEQUENCE...)" | |
518 (cond ((eq type 'vector) (apply 'vconcat seqs)) | 529 (cond ((eq type 'vector) (apply 'vconcat seqs)) |
519 ((eq type 'string) (apply 'concat seqs)) | 530 ((eq type 'string) (apply 'concat seqs)) |
520 ((eq type 'list) (apply 'append (append seqs '(nil)))) | 531 ((eq type 'list) (apply 'append (append seqs '(nil)))) |
521 (t (error "Not a sequence type name: %s" type)))) | 532 (t (error "Not a sequence type name: %s" type)))) |
522 | 533 |
530 (defun nreconc (x y) | 541 (defun nreconc (x y) |
531 "Equivalent to (nconc (nreverse X) Y)." | 542 "Equivalent to (nconc (nreverse X) Y)." |
532 (nconc (nreverse x) y)) | 543 (nconc (nreverse x) y)) |
533 | 544 |
534 (defun list-length (x) | 545 (defun list-length (x) |
535 "Return the length of a list. Return nil if list is circular." | 546 "Return the length of list X. Return nil if list is circular." |
536 (let ((n 0) (fast x) (slow x)) | 547 (let ((n 0) (fast x) (slow x)) |
537 (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) | 548 (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) |
538 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) | 549 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) |
539 (if fast (if (cdr fast) nil (1+ n)) n))) | 550 (if fast (if (cdr fast) nil (1+ n)) n))) |
540 | 551 |
548 | 559 |
549 | 560 |
550 ;;; Property lists. | 561 ;;; Property lists. |
551 | 562 |
552 (defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el | 563 (defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el |
553 "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none." | 564 "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none. |
565 \n(fn SYMBOL PROPNAME &optional DEFAULT)" | |
554 (or (get sym tag) | 566 (or (get sym tag) |
555 (and def | 567 (and def |
556 (let ((plist (symbol-plist sym))) | 568 (let ((plist (symbol-plist sym))) |
557 (while (and plist (not (eq (car plist) tag))) | 569 (while (and plist (not (eq (car plist) tag))) |
558 (setq plist (cdr (cdr plist)))) | 570 (setq plist (cdr (cdr plist)))) |
559 (if plist (car (cdr plist)) def))))) | 571 (if plist (car (cdr plist)) def))))) |
560 | 572 |
561 (defun getf (plist tag &optional def) | 573 (defun getf (plist tag &optional def) |
562 "Search PROPLIST for property PROPNAME; return its value or DEFAULT. | 574 "Search PROPLIST for property PROPNAME; return its value or DEFAULT. |
563 PROPLIST is a list of the sort returned by `symbol-plist'." | 575 PROPLIST is a list of the sort returned by `symbol-plist'. |
576 \n(fn PROPLIST PROPNAME &optional DEFAULT)" | |
564 (setplist '--cl-getf-symbol-- plist) | 577 (setplist '--cl-getf-symbol-- plist) |
565 (or (get '--cl-getf-symbol-- tag) | 578 (or (get '--cl-getf-symbol-- tag) |
566 ;; Originally we called get* here, | 579 ;; Originally we called get* here, |
567 ;; but that fails, because get* has a compiler macro | 580 ;; but that fails, because get* has a compiler macro |
568 ;; definition that uses getf! | 581 ;; definition that uses getf! |
580 (let ((p (cdr plist))) | 593 (let ((p (cdr plist))) |
581 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) | 594 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) |
582 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) | 595 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) |
583 | 596 |
584 (defun cl-remprop (sym tag) | 597 (defun cl-remprop (sym tag) |
585 "Remove from SYMBOL's plist the property PROP and its value." | 598 "Remove from SYMBOL's plist the property PROPNAME and its value. |
599 \n(fn SYMBOL PROPNAME)" | |
586 (let ((plist (symbol-plist sym))) | 600 (let ((plist (symbol-plist sym))) |
587 (if (and plist (eq tag (car plist))) | 601 (if (and plist (eq tag (car plist))) |
588 (progn (setplist sym (cdr (cdr plist))) t) | 602 (progn (setplist sym (cdr (cdr plist))) t) |
589 (cl-do-remf plist tag)))) | 603 (cl-do-remf plist tag)))) |
590 (defalias 'remprop 'cl-remprop) | 604 (defalias 'remprop 'cl-remprop) |