Mercurial > emacs
comparison lisp/emacs-lisp/cl.el @ 88155:d7ddb3e565de
sync with trunk
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Mon, 16 Jan 2006 00:03:54 +0000 |
parents | b9d1a3c5291e |
children |
comparison
equal
deleted
inserted
replaced
88154:8ce476d3ba36 | 88155:d7ddb3e565de |
---|---|
1 ;;; cl.el --- Common Lisp extensions for Emacs -*-byte-compile-dynamic: t;-*- | 1 ;;; cl.el --- Common Lisp extensions for Emacs -*-byte-compile-dynamic: t;-*- |
2 | 2 |
3 ;; Copyright (C) 1993 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1993, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
4 | 4 |
5 ;; Author: Dave Gillespie <daveg@synaptics.com> | 5 ;; Author: Dave Gillespie <daveg@synaptics.com> |
6 ;; Version: 2.02 | 6 ;; Version: 2.02 |
7 ;; Keywords: extensions | 7 ;; Keywords: extensions |
8 | 8 |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
19 ;; GNU General Public License for more details. | 19 ;; GNU General Public License for more details. |
20 | 20 |
21 ;; You should have received a copy of the GNU General Public License | 21 ;; You should have received a copy of the GNU General Public License |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | 22 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
24 ;; Boston, MA 02111-1307, USA. | 24 ;; Boston, MA 02110-1301, USA. |
25 | 25 |
26 ;;; Commentary: | 26 ;;; Commentary: |
27 | 27 |
28 ;; These are extensions to Emacs Lisp that provide a degree of | 28 ;; These are extensions to Emacs Lisp that provide a degree of |
29 ;; Common Lisp compatibility, beyond what is already built-in | 29 ;; Common Lisp compatibility, beyond what is already built-in |
106 printer proceeds to the next function on the list. | 106 printer proceeds to the next function on the list. |
107 | 107 |
108 This variable is not used at present, but it is defined in hopes that | 108 This variable is not used at present, but it is defined in hopes that |
109 a future Emacs interpreter will be able to use it.") | 109 a future Emacs interpreter will be able to use it.") |
110 | 110 |
111 | 111 (add-hook 'cl-unload-hook 'cl-cannot-unload) |
112 ;;; Predicates. | 112 (defun cl-cannot-unload () |
113 | 113 (error "Cannot unload the feature `cl'")) |
114 (defun eql (a b) ; See compiler macro in cl-macs.el | |
115 "T if the two args are the same Lisp object. | |
116 Floating-point numbers of equal value are `eql', but they may not be `eq'." | |
117 (if (numberp a) | |
118 (equal a b) | |
119 (eq a b))) | |
120 | |
121 | 114 |
122 ;;; Generalized variables. These macros are defined here so that they | 115 ;;; Generalized variables. These macros are defined here so that they |
123 ;;; can safely be used in .emacs files. | 116 ;;; can safely be used in .emacs files. |
124 | 117 |
125 (defmacro incf (place &optional x) | 118 (defmacro incf (place &optional x) |
157 | 150 |
158 (defmacro pushnew (x place &rest keys) | 151 (defmacro pushnew (x place &rest keys) |
159 "(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. |
160 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 |
161 an element already on the list. | 154 an element already on the list. |
162 Keywords supported: :test :test-not :key" | 155 \nKeywords supported: :test :test-not :key |
156 \n(fn X PLACE [KEYWORD VALUE]...)" | |
163 (if (symbolp place) (list 'setq place (list* 'adjoin x place keys)) | 157 (if (symbolp place) (list 'setq place (list* 'adjoin x place keys)) |
164 (list* 'callf2 'adjoin x place keys))) | 158 (list* 'callf2 'adjoin x place keys))) |
165 | 159 |
166 (defun cl-set-elt (seq n val) | 160 (defun cl-set-elt (seq n val) |
167 (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))) |
251 If FORM is not a macro call, it is returned unchanged. | 245 If FORM is not a macro call, it is returned unchanged. |
252 Otherwise, the macro is expanded and the expansion is considered | 246 Otherwise, the macro is expanded and the expansion is considered |
253 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. |
254 | 248 |
255 The second optional arg ENVIRONMENT specifies an environment of macro | 249 The second optional arg ENVIRONMENT specifies an environment of macro |
256 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)" | |
257 (let ((cl-macro-environment cl-env)) | 252 (let ((cl-macro-environment cl-env)) |
258 (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)) |
259 (and (symbolp cl-macro) | 254 (and (symbolp cl-macro) |
260 (cdr (assq (symbol-name cl-macro) cl-env)))) | 255 (cdr (assq (symbol-name cl-macro) cl-env)))) |
261 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) | 256 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) |
295 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) | 290 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) |
296 | 291 |
297 | 292 |
298 ;;; Numbers. | 293 ;;; Numbers. |
299 | 294 |
300 (defun floatp-safe (x) | 295 (defun floatp-safe (object) |
301 "T if OBJECT is a floating point number. | 296 "Return t if OBJECT is a floating point number. |
302 On Emacs versions that lack floating-point support, this function | 297 On Emacs versions that lack floating-point support, this function |
303 always returns nil." | 298 always returns nil." |
304 (and (numberp x) (not (integerp x)))) | 299 (and (numberp object) (not (integerp object)))) |
305 | 300 |
306 (defun plusp (x) | 301 (defun plusp (number) |
307 "T if NUMBER is positive." | 302 "Return t if NUMBER is positive." |
308 (> x 0)) | 303 (> number 0)) |
309 | 304 |
310 (defun minusp (x) | 305 (defun minusp (number) |
311 "T if NUMBER is negative." | 306 "Return t if NUMBER is negative." |
312 (< x 0)) | 307 (< number 0)) |
313 | 308 |
314 (defun oddp (x) | 309 (defun oddp (integer) |
315 "T if INTEGER is odd." | 310 "Return t if INTEGER is odd." |
316 (eq (logand x 1) 1)) | 311 (eq (logand integer 1) 1)) |
317 | 312 |
318 (defun evenp (x) | 313 (defun evenp (integer) |
319 "T if INTEGER is even." | 314 "Return t if INTEGER is even." |
320 (eq (logand x 1) 0)) | 315 (eq (logand integer 1) 0)) |
321 | 316 |
322 (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))) |
323 | 318 |
324 ;;; The following are actually set by cl-float-limits. | 319 ;;; The following are actually set by cl-float-limits. |
325 (defconst most-positive-float nil) | 320 (defconst most-positive-float nil) |
339 (defun mapcar* (cl-func cl-x &rest cl-rest) | 334 (defun mapcar* (cl-func cl-x &rest cl-rest) |
340 "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. |
341 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, |
342 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 |
343 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 |
344 `mapcar' function extended to arbitrary sequence types." | 339 `mapcar' function extended to arbitrary sequence types. |
340 \n(fn FUNCTION SEQ...)" | |
345 (if cl-rest | 341 (if cl-rest |
346 (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))) |
347 (cl-mapcar-many cl-func (cons cl-x cl-rest)) | 343 (cl-mapcar-many cl-func (cons cl-x cl-rest)) |
348 (let ((cl-res nil) (cl-y (car cl-rest))) | 344 (let ((cl-res nil) (cl-y (car cl-rest))) |
349 (while (and cl-x cl-y) | 345 (while (and cl-x cl-y) |
498 ;; (if (< n m) (nthcdr (- m n) x) x))) | 494 ;; (if (< n m) (nthcdr (- m n) x) x))) |
499 ;; (while (consp (cdr x)) (pop x)) | 495 ;; (while (consp (cdr x)) (pop x)) |
500 ;; x)) | 496 ;; x)) |
501 | 497 |
502 (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 |
503 "Return a new list with specified args as elements, cons'd to last arg. | 499 "Return a new list with specified ARGs as elements, consed to last ARG. |
504 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 |
505 `(cons A (cons B (cons C D)))'." | 501 `(cons A (cons B (cons C D)))'. |
502 \n(fn ARG...)" | |
506 (cond ((not rest) arg) | 503 (cond ((not rest) arg) |
507 ((not (cdr rest)) (cons arg (car rest))) | 504 ((not (cdr rest)) (cons arg (car rest))) |
508 (t (let* ((n (length rest)) | 505 (t (let* ((n (length rest)) |
509 (copy (copy-sequence rest)) | 506 (copy (copy-sequence rest)) |
510 (last (nthcdr (- n 2) copy))) | 507 (last (nthcdr (- n 2) copy))) |
517 (while (and (consp list) (not (eq list sublist))) | 514 (while (and (consp list) (not (eq list sublist))) |
518 (push (pop list) res)) | 515 (push (pop list) res)) |
519 (nreverse res))) | 516 (nreverse res))) |
520 | 517 |
521 (defun copy-list (list) | 518 (defun copy-list (list) |
522 "Return a copy of a list, which may be a dotted list. | 519 "Return a copy of LIST, which may be a dotted list. |
523 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." |
524 (if (consp list) | 521 (if (consp list) |
525 (let ((res nil)) | 522 (let ((res nil)) |
526 (while (consp list) (push (pop list) res)) | 523 (while (consp list) (push (pop list) res)) |
527 (prog1 (nreverse res) (setcdr res list))) | 524 (prog1 (nreverse res) (setcdr res list))) |
528 (car list))) | 525 (car list))) |
539 (defalias 'cl-mod 'mod*) | 536 (defalias 'cl-mod 'mod*) |
540 | 537 |
541 (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 |
542 "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. |
543 Otherwise, return LIST unmodified. | 540 Otherwise, return LIST unmodified. |
544 Keywords supported: :test :test-not :key" | 541 \nKeywords supported: :test :test-not :key |
542 \n(fn ITEM LIST [KEYWORD VALUE]...)" | |
545 (cond ((or (equal cl-keys '(:test eq)) | 543 (cond ((or (equal cl-keys '(:test eq)) |
546 (and (null cl-keys) (not (numberp cl-item)))) | 544 (and (null cl-keys) (not (numberp cl-item)))) |
547 (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))) |
548 ((or (equal cl-keys '(:test equal)) (null cl-keys)) | 546 ((or (equal cl-keys '(:test equal)) (null cl-keys)) |
549 (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))) |
550 (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) | 548 (t (apply 'cl-adjoin cl-item cl-list cl-keys)))) |
551 | 549 |
552 (defun subst (cl-new cl-old cl-tree &rest cl-keys) | 550 (defun subst (cl-new cl-old cl-tree &rest cl-keys) |
553 "Substitute NEW for OLD everywhere in TREE (non-destructively). | 551 "Substitute NEW for OLD everywhere in TREE (non-destructively). |
554 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. |
555 Keywords supported: :test :test-not :key" | 553 \nKeywords supported: :test :test-not :key |
554 \n(fn NEW OLD TREE [KEYWORD VALUE]...)" | |
556 (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)))) |
557 (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) |
558 (cl-do-subst cl-new cl-old cl-tree))) | 557 (cl-do-subst cl-new cl-old cl-tree))) |
559 | 558 |
560 (defun cl-do-subst (cl-new cl-old cl-tree) | 559 (defun cl-do-subst (cl-new cl-old cl-tree) |
564 (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) | 563 (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) |
565 (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))) |
566 cl-tree (cons a d)))) | 565 cl-tree (cons a d)))) |
567 (t cl-tree))) | 566 (t cl-tree))) |
568 | 567 |
569 (defun acons (a b c) (cons (cons a b) c)) | 568 (defun acons (key value alist) |
570 (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)) | |
571 | 579 |
572 | 580 |
573 ;;; Miscellaneous. | 581 ;;; Miscellaneous. |
574 | 582 |
575 (put 'cl-assertion-failed 'error-conditions '(error)) | 583 (put 'cl-assertion-failed 'error-conditions '(error)) |
577 | 585 |
578 (defvar cl-fake-autoloads nil | 586 (defvar cl-fake-autoloads nil |
579 "Non-nil means don't make CL functions autoload.") | 587 "Non-nil means don't make CL functions autoload.") |
580 | 588 |
581 ;;; Autoload the other portions of the package. | 589 ;;; Autoload the other portions of the package. |
582 ;; We want to replace the basic versions of dolist, dotimes below. | 590 ;; We want to replace the basic versions of dolist, dotimes, declare below. |
583 (fmakunbound 'dolist) | 591 (fmakunbound 'dolist) |
584 (fmakunbound 'dotimes) | 592 (fmakunbound 'dotimes) |
593 (fmakunbound 'declare) | |
585 (mapcar (function | 594 (mapcar (function |
586 (lambda (set) | 595 (lambda (set) |
587 (let ((file (if cl-fake-autoloads "<none>" (car set)))) | 596 (let ((file (if cl-fake-autoloads "<none>" (car set)))) |
588 (mapcar (function | 597 (mapcar (function |
589 (lambda (func) | 598 (lambda (func) |
693 | 702 |
694 (provide 'cl) | 703 (provide 'cl) |
695 | 704 |
696 (run-hooks 'cl-load-hook) | 705 (run-hooks 'cl-load-hook) |
697 | 706 |
707 ;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 | |
698 ;;; cl.el ends here | 708 ;;; cl.el ends here |