Mercurial > emacs
comparison lisp/emacs-lisp/cl.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 59b6666e38f9 |
children | f9a65d7ebd29 |
comparison
equal
deleted
inserted
replaced
90184:9e5e2f01c7ab | 90185:5b029ff3b08d |
---|---|
110 | 110 |
111 (add-hook 'cl-unload-hook 'cl-cannot-unload) | 111 (add-hook 'cl-unload-hook 'cl-cannot-unload) |
112 (defun cl-cannot-unload () | 112 (defun cl-cannot-unload () |
113 (error "Cannot unload the feature `cl'")) | 113 (error "Cannot unload the feature `cl'")) |
114 | 114 |
115 ;;; Predicates. | |
116 | |
117 (defun eql (a b) ; See compiler macro in cl-macs.el | |
118 "Return t if the two args are the same Lisp object. | |
119 Floating-point numbers of equal value are `eql', but they may not be `eq'." | |
120 (if (numberp a) | |
121 (equal a b) | |
122 (eq a b))) | |
123 | |
124 | |
125 ;;; Generalized variables. These macros are defined here so that they | 115 ;;; Generalized variables. These macros are defined here so that they |
126 ;;; can safely be used in .emacs files. | 116 ;;; can safely be used in .emacs files. |
127 | 117 |
128 (defmacro incf (place &optional x) | 118 (defmacro incf (place &optional x) |
129 "Increment PLACE by X (1 by default). | 119 "Increment PLACE by X (1 by default). |
160 | 150 |
161 (defmacro pushnew (x place &rest keys) | 151 (defmacro pushnew (x place &rest keys) |
162 "(pushnew X PLACE): insert X at the head of the list if not already there. | 152 "(pushnew X PLACE): insert X at the head of the list if not already there. |
163 Like (push X PLACE), except that the list is unmodified if X is `eql' to | 153 Like (push X PLACE), except that the list is unmodified if X is `eql' to |
164 an element already on the list. | 154 an element already on the list. |
165 Keywords supported: :test :test-not :key" | 155 \nKeywords supported: :test :test-not :key |
156 \n(fn X PLACE [KEYWORD VALUE]...)" | |
166 (if (symbolp place) (list 'setq place (list* 'adjoin x place keys)) | 157 (if (symbolp place) (list 'setq place (list* 'adjoin x place keys)) |
167 (list* 'callf2 'adjoin x place keys))) | 158 (list* 'callf2 'adjoin x place keys))) |
168 | 159 |
169 (defun cl-set-elt (seq n val) | 160 (defun cl-set-elt (seq n val) |
170 (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) | 161 (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) |
254 If FORM is not a macro call, it is returned unchanged. | 245 If FORM is not a macro call, it is returned unchanged. |
255 Otherwise, the macro is expanded and the expansion is considered | 246 Otherwise, the macro is expanded and the expansion is considered |
256 in place of FORM. When a non-macro-call results, it is returned. | 247 in place of FORM. When a non-macro-call results, it is returned. |
257 | 248 |
258 The second optional arg ENVIRONMENT specifies an environment of macro | 249 The second optional arg ENVIRONMENT specifies an environment of macro |
259 definitions to shadow the loaded ones for use in file byte-compilation." | 250 definitions to shadow the loaded ones for use in file byte-compilation. |
251 \n(fn FORM &optional ENVIRONMENT)" | |
260 (let ((cl-macro-environment cl-env)) | 252 (let ((cl-macro-environment cl-env)) |
261 (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) | 253 (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) |
262 (and (symbolp cl-macro) | 254 (and (symbolp cl-macro) |
263 (cdr (assq (symbol-name cl-macro) cl-env)))) | 255 (cdr (assq (symbol-name cl-macro) cl-env)))) |
264 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) | 256 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) |
298 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) | 290 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) |
299 | 291 |
300 | 292 |
301 ;;; Numbers. | 293 ;;; Numbers. |
302 | 294 |
303 (defun floatp-safe (x) | 295 (defun floatp-safe (object) |
304 "Return t if OBJECT is a floating point number. | 296 "Return t if OBJECT is a floating point number. |
305 On Emacs versions that lack floating-point support, this function | 297 On Emacs versions that lack floating-point support, this function |
306 always returns nil." | 298 always returns nil." |
307 (and (numberp x) (not (integerp x)))) | 299 (and (numberp object) (not (integerp object)))) |
308 | 300 |
309 (defun plusp (x) | 301 (defun plusp (number) |
310 "Return t if NUMBER is positive." | 302 "Return t if NUMBER is positive." |
311 (> x 0)) | 303 (> number 0)) |
312 | 304 |
313 (defun minusp (x) | 305 (defun minusp (number) |
314 "Return t if NUMBER is negative." | 306 "Return t if NUMBER is negative." |
315 (< x 0)) | 307 (< number 0)) |
316 | 308 |
317 (defun oddp (x) | 309 (defun oddp (integer) |
318 "Return t if INTEGER is odd." | 310 "Return t if INTEGER is odd." |
319 (eq (logand x 1) 1)) | 311 (eq (logand integer 1) 1)) |
320 | 312 |
321 (defun evenp (x) | 313 (defun evenp (integer) |
322 "Return t if INTEGER is even." | 314 "Return t if INTEGER is even." |
323 (eq (logand x 1) 0)) | 315 (eq (logand integer 1) 0)) |
324 | 316 |
325 (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) | 317 (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) |
326 | 318 |
327 ;;; The following are actually set by cl-float-limits. | 319 ;;; The following are actually set by cl-float-limits. |
328 (defconst most-positive-float nil) | 320 (defconst most-positive-float nil) |
342 (defun mapcar* (cl-func cl-x &rest cl-rest) | 334 (defun mapcar* (cl-func cl-x &rest cl-rest) |
343 "Apply FUNCTION to each element of SEQ, and make a list of the results. | 335 "Apply FUNCTION to each element of SEQ, and make a list of the results. |
344 If there are several SEQs, FUNCTION is called with that many arguments, | 336 If there are several SEQs, FUNCTION is called with that many arguments, |
345 and mapping stops as soon as the shortest list runs out. With just one | 337 and mapping stops as soon as the shortest list runs out. With just one |
346 SEQ, this is like `mapcar'. With several, it is like the Common Lisp | 338 SEQ, this is like `mapcar'. With several, it is like the Common Lisp |
347 `mapcar' function extended to arbitrary sequence types." | 339 `mapcar' function extended to arbitrary sequence types. |
340 \n(fn FUNCTION SEQ...)" | |
348 (if cl-rest | 341 (if cl-rest |
349 (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) | 342 (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) |
350 (cl-mapcar-many cl-func (cons cl-x cl-rest)) | 343 (cl-mapcar-many cl-func (cons cl-x cl-rest)) |
351 (let ((cl-res nil) (cl-y (car cl-rest))) | 344 (let ((cl-res nil) (cl-y (car cl-rest))) |
352 (while (and cl-x cl-y) | 345 (while (and cl-x cl-y) |
501 ;; (if (< n m) (nthcdr (- m n) x) x))) | 494 ;; (if (< n m) (nthcdr (- m n) x) x))) |
502 ;; (while (consp (cdr x)) (pop x)) | 495 ;; (while (consp (cdr x)) (pop x)) |
503 ;; x)) | 496 ;; x)) |
504 | 497 |
505 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el | 498 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el |
506 "Return a new list with specified args as elements, consed to last arg. | 499 "Return a new list with specified ARGs as elements, consed to last ARG. |
507 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to | 500 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to |
508 `(cons A (cons B (cons C D)))'." | 501 `(cons A (cons B (cons C D)))'. |
502 \n(fn ARG...)" | |
509 (cond ((not rest) arg) | 503 (cond ((not rest) arg) |
510 ((not (cdr rest)) (cons arg (car rest))) | 504 ((not (cdr rest)) (cons arg (car rest))) |
511 (t (let* ((n (length rest)) | 505 (t (let* ((n (length rest)) |
512 (copy (copy-sequence rest)) | 506 (copy (copy-sequence rest)) |
513 (last (nthcdr (- n 2) copy))) | 507 (last (nthcdr (- n 2) copy))) |
520 (while (and (consp list) (not (eq list sublist))) | 514 (while (and (consp list) (not (eq list sublist))) |
521 (push (pop list) res)) | 515 (push (pop list) res)) |
522 (nreverse res))) | 516 (nreverse res))) |
523 | 517 |
524 (defun copy-list (list) | 518 (defun copy-list (list) |
525 "Return a copy of a list, which may be a dotted list. | 519 "Return a copy of LIST, which may be a dotted list. |
526 The elements of the list are not copied, just the list structure itself." | 520 The elements of LIST are not copied, just the list structure itself." |
527 (if (consp list) | 521 (if (consp list) |
528 (let ((res nil)) | 522 (let ((res nil)) |
529 (while (consp list) (push (pop list) res)) | 523 (while (consp list) (push (pop list) res)) |
530 (prog1 (nreverse res) (setcdr res list))) | 524 (prog1 (nreverse res) (setcdr res list))) |
531 (car list))) | 525 (car list))) |
542 (defalias 'cl-mod 'mod*) | 536 (defalias 'cl-mod 'mod*) |
543 | 537 |
544 (defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs | 538 (defun adjoin (cl-item cl-list &rest cl-keys) ; See compiler macro in cl-macs |
545 "Return ITEM consed onto the front of LIST only if it's not already there. | 539 "Return ITEM consed onto the front of LIST only if it's not already there. |
546 Otherwise, return LIST unmodified. | 540 Otherwise, return LIST unmodified. |
547 Keywords supported: :test :test-not :key" | 541 \nKeywords supported: :test :test-not :key |
542 \n(fn ITEM LIST [KEYWORD VALUE]...)" | |
548 (cond ((or (equal cl-keys '(:test eq)) | 543 (cond ((or (equal cl-keys '(:test eq)) |
549 (and (null cl-keys) (not (numberp cl-item)))) | 544 (and (null cl-keys) (not (numberp cl-item)))) |
550 (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) | 545 (if (memq cl-item cl-list) cl-list (cons cl-item cl-list))) |
551 ((or (equal cl-keys '(:test equal)) (null cl-keys)) | 546 ((or (equal cl-keys '(:test equal)) (null cl-keys)) |
552 (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) | 547 (if (member cl-item cl-list) cl-list (cons cl-item cl-list))) |
553 (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) | 548 (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) |
554 | 549 |
555 (defun subst (cl-new cl-old cl-tree &rest cl-keys) | 550 (defun subst (cl-new cl-old cl-tree &rest cl-keys) |
556 "Substitute NEW for OLD everywhere in TREE (non-destructively). | 551 "Substitute NEW for OLD everywhere in TREE (non-destructively). |
557 Return a copy of TREE with all elements `eql' to OLD replaced by NEW. | 552 Return a copy of TREE with all elements `eql' to OLD replaced by NEW. |
558 Keywords supported: :test :test-not :key" | 553 \nKeywords supported: :test :test-not :key |
554 \n(fn NEW OLD TREE [KEYWORD VALUE]...)" | |
559 (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) | 555 (if (or cl-keys (and (numberp cl-old) (not (integerp cl-old)))) |
560 (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys) | 556 (apply 'sublis (list (cons cl-old cl-new)) cl-tree cl-keys) |
561 (cl-do-subst cl-new cl-old cl-tree))) | 557 (cl-do-subst cl-new cl-old cl-tree))) |
562 | 558 |
563 (defun cl-do-subst (cl-new cl-old cl-tree) | 559 (defun cl-do-subst (cl-new cl-old cl-tree) |
567 (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) | 563 (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) |
568 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) | 564 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) |
569 cl-tree (cons a d)))) | 565 cl-tree (cons a d)))) |
570 (t cl-tree))) | 566 (t cl-tree))) |
571 | 567 |
572 (defun acons (a b c) (cons (cons a b) c)) | 568 (defun acons (key value alist) |
573 (defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c)) | 569 "Add KEY and VALUE to ALIST. |
570 Return a new list with (cons KEY VALUE) as car and ALIST as cdr." | |
571 (cons (cons key value) alist)) | |
572 | |
573 (defun pairlis (keys values &optional alist) | |
574 "Make an alist from KEYS and VALUES. | |
575 Return a new alist composed by associating KEYS to corresponding VALUES; | |
576 the process stops as soon as KEYS or VALUES run out. | |
577 If ALIST is non-nil, the new pairs are prepended to it." | |
578 (nconc (mapcar* 'cons keys values) alist)) | |
574 | 579 |
575 | 580 |
576 ;;; Miscellaneous. | 581 ;;; Miscellaneous. |
577 | 582 |
578 (put 'cl-assertion-failed 'error-conditions '(error)) | 583 (put 'cl-assertion-failed 'error-conditions '(error)) |
697 | 702 |
698 (provide 'cl) | 703 (provide 'cl) |
699 | 704 |
700 (run-hooks 'cl-load-hook) | 705 (run-hooks 'cl-load-hook) |
701 | 706 |
702 ;;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 | 707 ;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 |
703 ;;; cl.el ends here | 708 ;;; cl.el ends here |