Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 8626e4521993
children 697ef44129c6
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
74 ((eq type 'vector) (if (vectorp x) x (vconcat x))) 74 ((eq type 'vector) (if (vectorp x) x (vconcat x)))
75 ((eq type 'string) (if (stringp x) x (concat x))) 75 ((eq type 'string) (if (stringp x) x (concat x)))
76 ((eq type 'array) (if (arrayp x) x (vconcat x))) 76 ((eq type 'array) (if (arrayp x) x (vconcat x)))
77 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) 77 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
78 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) 78 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
79 ((and (eq type 'character) (numberp x) (char-or-char-int-p x)
80 (int-char x)))
79 ((eq type 'float) (float x)) 81 ((eq type 'float) (float x))
80 ((eq type 'bit-vector) (if (bit-vector-p x) x 82 ((eq type 'bit-vector) (if (bit-vector-p x) x
81 (apply 'bit-vector (append x nil)))) 83 (apply 'bit-vector (append x nil))))
82 ((eq type 'weak-list) 84 ((eq type 'weak-list)
83 (if (weak-list-p x) x 85 (if (weak-list-p x) x
106 (char-equal (downcase x) (downcase y))))) 108 (char-equal (downcase x) (downcase y)))))
107 ((numberp x) 109 ((numberp x)
108 (and (numberp y) (= x y))) 110 (and (numberp y) (= x y)))
109 ((consp x) 111 ((consp x)
110 ;; XEmacs change 112 ;; XEmacs change
111 (while (and (consp x) (consp y) (equalp (cl-pop x) (cl-pop y)))) 113 (while (and (consp x) (consp y) (equalp (car x) (car y)))
114 (cl-pop x) (cl-pop y))
112 (and (not (consp x)) (equalp x y))) 115 (and (not (consp x)) (equalp x y)))
113 ((vectorp x) 116 ((vectorp x)
114 (and (vectorp y) (= (length x) (length y)) 117 (and (vectorp y) (= (length x) (length y))
115 (let ((i (length x))) 118 (let ((i (length x)))
116 (while (and (>= (setq i (1- i)) 0) 119 (while (and (>= (setq i (1- i)) 0)
178 (cl-push (funcall cl-func cl-list) cl-res) 181 (cl-push (funcall cl-func cl-list) cl-res)
179 (setq cl-list (cdr cl-list))) 182 (setq cl-list (cdr cl-list)))
180 (nreverse cl-res)))) 183 (nreverse cl-res))))
181 184
182 185
183 ;; mapc is now in C, renamed from `mapc-internal'. 186 (defun mapc (cl-func cl-seq &rest cl-rest)
184 187 "Like `mapcar', but does not accumulate values returned by the function."
185 ;(defun mapc (cl-func cl-seq &rest cl-rest) 188 (if cl-rest
186 ; "Like `mapcar', but does not accumulate values returned by the function." 189 (apply 'map nil cl-func cl-seq cl-rest)
187 ; (if cl-rest 190 ;; XEmacs change: in the simplest case we call mapc-internal,
188 ; (apply 'map nil cl-func cl-seq cl-rest) 191 ;; which really doesn't accumulate any results.
189 ; ;; XEmacs change: we call mapc-internal, which really doesn't 192 (mapc-internal cl-func cl-seq))
190 ; ;; accumulate any results. 193 cl-seq)
191 ; (mapc-internal cl-func cl-seq))
192 ; cl-seq)
193 194
194 (defun mapl (cl-func cl-list &rest cl-rest) 195 (defun mapl (cl-func cl-list &rest cl-rest)
195 "Like `maplist', but does not accumulate values returned by the function." 196 "Like `maplist', but does not accumulate values returned by the function."
196 (if cl-rest 197 (if cl-rest
197 (apply 'maplist cl-func cl-list cl-rest) 198 (apply 'maplist cl-func cl-list cl-rest)
635 636
636 ;;; Property lists. 637 ;;; Property lists.
637 638
638 ;; XEmacs: our `get' groks DEFAULT. 639 ;; XEmacs: our `get' groks DEFAULT.
639 (defalias 'get* 'get) 640 (defalias 'get* 'get)
640 641 (defalias 'getf 'plist-get)
641 (defun getf (plist tag &optional def)
642 "Search PROPLIST for property PROPNAME; return its value or DEFAULT.
643 PROPLIST is a list of the sort returned by `symbol-plist'."
644 (setplist '--cl-getf-symbol-- plist)
645 (or (get '--cl-getf-symbol-- tag)
646 (and def (get* '--cl-getf-symbol-- tag def))))
647 642
648 (defun cl-set-getf (plist tag val) 643 (defun cl-set-getf (plist tag val)
649 (let ((p plist)) 644 (let ((p plist))
650 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) 645 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
651 (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) 646 (if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
653 (defun cl-do-remf (plist tag) 648 (defun cl-do-remf (plist tag)
654 (let ((p (cdr plist))) 649 (let ((p (cdr plist)))
655 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) 650 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
656 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) 651 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
657 652
658 (defun cl-remprop (sym tag)
659 "Remove from SYMBOL's plist the property PROP and its value."
660 (let ((plist (symbol-plist sym)))
661 (if (and plist (eq tag (car plist)))
662 (progn (setplist sym (cdr (cdr plist))) t)
663 (cl-do-remf plist tag))))
664 (or (and (fboundp 'remprop) (subrp (symbol-function 'remprop)))
665 (defalias 'remprop 'cl-remprop))
666
667
668
669 ;;; Hash tables. 653 ;;; Hash tables.
670 654
671 ;; The `regular' Common Lisp hash-table stuff has been moved into C. 655 ;; The `regular' Common Lisp hash-table stuff has been moved into C.
672 ;; Only backward compatibility stuff remains here. 656 ;; Only backward compatibility stuff remains here.
673 (defun make-hashtable (size &optional test) 657 (defun make-hashtable (size &optional test)
674 (make-hash-table :size size :test test :type 'non-weak)) 658 (make-hash-table :test test :size size))
675 (defun make-weak-hashtable (size &optional test) 659 (defun make-weak-hashtable (size &optional test)
676 (make-hash-table :size size :test test :type 'weak)) 660 (make-hash-table :test test :size size :weakness t))
677 (defun make-key-weak-hashtable (size &optional test) 661 (defun make-key-weak-hashtable (size &optional test)
678 (make-hash-table :size size :test test :type 'key-weak)) 662 (make-hash-table :test test :size size :weakness 'key))
679 (defun make-value-weak-hashtable (size &optional test) 663 (defun make-value-weak-hashtable (size &optional test)
680 (make-hash-table :size size :test test :type 'value-weak)) 664 (make-hash-table :test test :size size :weakness 'value))
681 665
682 (define-obsolete-function-alias 'hashtablep 'hash-table-p) 666 (define-obsolete-function-alias 'hashtablep 'hash-table-p)
683 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count) 667 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count)
684 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test) 668 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test)
685 (define-obsolete-function-alias 'hashtable-type 'hash-table-type) 669 (define-obsolete-function-alias 'hashtable-type 'hash-table-type)
688 672
689 (make-obsolete 'make-hashtable 'make-hash-table) 673 (make-obsolete 'make-hashtable 'make-hash-table)
690 (make-obsolete 'make-weak-hashtable 'make-hash-table) 674 (make-obsolete 'make-weak-hashtable 'make-hash-table)
691 (make-obsolete 'make-key-weak-hashtable 'make-hash-table) 675 (make-obsolete 'make-key-weak-hashtable 'make-hash-table)
692 (make-obsolete 'make-value-weak-hashtable 'make-hash-table) 676 (make-obsolete 'make-value-weak-hashtable 'make-hash-table)
677 (make-obsolete 'hash-table-type 'hash-table-weakness)
693 678
694 (when (fboundp 'x-keysym-hash-table) 679 (when (fboundp 'x-keysym-hash-table)
695 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table)) 680 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table))
696 681
697 ;; Compatibility stuff for old kludgy cl.el hash table implementation 682 ;; Compatibility stuff for old kludgy cl.el hash table implementation