Mercurial > hg > xemacs-beta

comparison lisp/cl/cl-extra.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 0293115a14e9
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details. 19 ;; 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 XEmacs; see the file COPYING. If not, write to the Free 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
23 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
24 24 ;; 02111-1307, USA.
25 ;;; Synched up with: FSF 19.30. 25
26 ;;; Synched up with: FSF 19.34.
26 27
27 ;;; Commentary: 28 ;;; Commentary:
28 29
29 ;; These are extensions to Emacs Lisp that provide a degree of 30 ;; These are extensions to Emacs Lisp that provide a degree of
30 ;; Common Lisp compatibility, beyond what is already built-in 31 ;; Common Lisp compatibility, beyond what is already built-in
83 numbers of different types (float vs. integer), and also compares 84 numbers of different types (float vs. integer), and also compares
84 strings case-insensitively." 85 strings case-insensitively."
85 (cond ((eq x y) t) 86 (cond ((eq x y) t)
86 ((stringp x) 87 ((stringp x)
87 (and (stringp y) (= (length x) (length y)) 88 (and (stringp y) (= (length x) (length y))
88 (or (equal x y) 89 (or (string-equal x y)
89 (equal (downcase x) (downcase y))))) ; lazy but simple! 90 (string-equal (downcase x) (downcase y))))) ; lazy but simple!
90 ((numberp x) 91 ((numberp x)
91 (and (numberp y) (= x y))) 92 (and (numberp y) (= x y)))
92 ((consp x) 93 ((consp x)
94 ;; XEmacs change
93 (while (and (consp x) (consp y) (equalp (cl-pop x) (cl-pop y)))) 95 (while (and (consp x) (consp y) (equalp (cl-pop x) (cl-pop y))))
94 (and (not (consp x)) (equalp x y))) 96 (and (not (consp x)) (equalp x y)))
95 ((vectorp x) 97 ((vectorp x)
96 (and (vectorp y) (= (length x) (length y)) 98 (and (vectorp y) (= (length x) (length y))
97 (let ((i (length x))) 99 (let ((i (length x)))
371 a))) 373 a)))
372 374
373 (defun isqrt (a) 375 (defun isqrt (a)
374 "Return the integer square root of the argument." 376 "Return the integer square root of the argument."
375 (if (and (integerp a) (> a 0)) 377 (if (and (integerp a) (> a 0))
378 ;; XEmacs change
376 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000) 379 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000)
377 ((>= a 100) 100) (t 10))) 380 ((>= a 100) 100) (t 10)))
378 g2) 381 g2)
379 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) 382 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
380 (setq g g2)) 383 (setq g g2))
381 g) 384 g)
382 (if (eq a 0) 0 (signal 'arith-error nil)))) 385 (if (eq a 0) 0 (signal 'arith-error nil))))
383 386
384 (defun cl-expt (x y) 387 (defun cl-expt (x y)
385 "Return X raised to the power of Y. Works only for integer arguments." 388 "Return X raised to the power of Y. Works only for integer arguments."
386 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) x 0)) 389 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0))
387 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) 390 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2)))))
388 (or (and (fboundp 'expt) (subrp (symbol-function 'expt))) 391 (or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
389 (defalias 'expt 'cl-expt)) 392 (defalias 'expt 'cl-expt))
390 393
391 (defun floor* (x &optional y) 394 (defun floor* (x &optional y)
591 (if (numberp sublist) (equal sublist list) (eq sublist list))) 594 (if (numberp sublist) (equal sublist list) (eq sublist list)))
592 595
593 (defun cl-copy-tree (tree &optional vecp) 596 (defun cl-copy-tree (tree &optional vecp)
594 "Make a copy of TREE. 597 "Make a copy of TREE.
595 If TREE is a cons cell, this recursively copies both its car and its cdr. 598 If TREE is a cons cell, this recursively copies both its car and its cdr.
596 Constrast to copy-sequence, which copies only along the cdrs. With second 599 Contrast to copy-sequence, which copies only along the cdrs. With second
597 argument VECP, this copies vectors as well as conses." 600 argument VECP, this copies vectors as well as conses."
598 (if (consp tree) 601 (if (consp tree)
599 (let ((p (setq tree (copy-list tree)))) 602 (let ((p (setq tree (copy-list tree))))
600 (while (consp p) 603 (while (consp p)
601 (if (or (consp (car p)) (and vecp (vectorp (car p)))) 604 (if (or (consp (car p)) (and vecp (vectorp (car p))))
653 ;;; Hash tables. 656 ;;; Hash tables.
654 657
655 (defun make-hash-table (&rest cl-keys) 658 (defun make-hash-table (&rest cl-keys)
656 "Make an empty Common Lisp-style hash-table. 659 "Make an empty Common Lisp-style hash-table.
657 If :test is `eq', `eql', or `equal', this can use XEmacs built-in hash-tables. 660 If :test is `eq', `eql', or `equal', this can use XEmacs built-in hash-tables.
658 In XEmacs, or with a different test, this internally uses a-lists. 661 In Emacs 19, or with a different test, this internally uses a-lists.
659 Keywords supported: :test :size 662 Keywords supported: :test :size
660 The Common Lisp keywords :rehash-size and :rehash-threshold are ignored." 663 The Common Lisp keywords :rehash-size and :rehash-threshold are ignored."
661 (let ((cl-test (or (car (cdr (memq ':test cl-keys))) 'eql)) 664 (let ((cl-test (or (car (cdr (memq ':test cl-keys))) 'eql))
662 (cl-size (or (car (cdr (memq ':size cl-keys))) 20))) 665 (cl-size (or (car (cdr (memq ':size cl-keys))) 20)))
666 ;; XEmacs change
663 (if (and (memq cl-test '(eq eql equal)) (fboundp 'make-hashtable)) 667 (if (and (memq cl-test '(eq eql equal)) (fboundp 'make-hashtable))
664 (funcall 'make-hashtable cl-size cl-test) 668 (funcall 'make-hashtable cl-size cl-test)
665 (list 'cl-hash-table-tag cl-test 669 (list 'cl-hash-table-tag cl-test
666 (if (> cl-size 1) (make-vector cl-size 0) 670 (if (> cl-size 1) (make-vector cl-size 0)
667 (let ((sym (make-symbol "--hashsym--"))) (set sym nil) sym)) 671 (let ((sym (make-symbol "--hashsym--"))) (set sym nil) sym))
891 (lambda (x) 895 (lambda (x)
892 (list 'list '(quote quote) x))) 896 (list 'list '(quote quote) x)))
893 cl-closure-vars) 897 cl-closure-vars)
894 '((quote --cl-rest--))))))) 898 '((quote --cl-rest--)))))))
895 (list (car form) (list* 'lambda (cadadr form) body)))) 899 (list (car form) (list* 'lambda (cadadr form) body))))
896 form)) 900 (let ((found (assq (cadr form) env)))
901 (if (eq (cadr (caddr found)) 'cl-labels-args)
902 (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
903 form))))
897 ((memq (car form) '(defun defmacro)) 904 ((memq (car form) '(defun defmacro))
898 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) 905 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
899 ((and (eq (car form) 'progn) (not (cddr form))) 906 ((and (eq (car form) 'progn) (not (cddr form)))
900 (cl-macroexpand-all (nth 1 form) env)) 907 (cl-macroexpand-all (nth 1 form) env))
901 ((eq (car form) 'setq) 908 ((eq (car form) 'setq)