Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 227:0e522484dd2a r20-5b12

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b12
author cvs
date Mon, 13 Aug 2007 10:12:37 +0200
parents 41ff10fd062f
children 11cf20601dec
comparison
equal deleted inserted replaced
226:eea38c7ad7b4 227:0e522484dd2a
73 ((eq type 'string) (if (stringp x) x (concat x))) 73 ((eq type 'string) (if (stringp x) x (concat x)))
74 ((eq type 'array) (if (arrayp x) x (vconcat x))) 74 ((eq type 'array) (if (arrayp x) x (vconcat x)))
75 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) 75 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
76 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) 76 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
77 ((eq type 'float) (float x)) 77 ((eq type 'float) (float x))
78 ((eq type 'bit-vector) (if (bit-vector-p x) x
79 (apply 'bit-vector (append x nil))))
80 ((eq type 'weak-list)
81 (if (weak-list-p x) x
82 (let ((wl (make-weak-list)))
83 (set-weak-list-list wl (if (listp x) x (append x nil)))
84 wl)))
78 ((typep x type) x) 85 ((typep x type) x)
79 (t (error "Can't coerce %s to type %s" x type)))) 86 (t (error "Can't coerce %s to type %s" x type))))
80 87
81 88
82 ;;; Predicates. 89 ;;; Predicates.
620 (defalias 'copy-tree 'cl-copy-tree)) 627 (defalias 'copy-tree 'cl-copy-tree))
621 628
622 629
623 ;;; Property lists. 630 ;;; Property lists.
624 631
625 (defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el 632 ;; XEmacs: our `get' groks DEFAULT.
626 "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none." 633 (defalias 'get* 'get)
627 (or (get sym tag)
628 (and def
629 (let ((plist (symbol-plist sym)))
630 (while (and plist (not (eq (car plist) tag)))
631 (setq plist (cdr (cdr plist))))
632 (if plist (car (cdr plist)) def)))))
633 634
634 (defun getf (plist tag &optional def) 635 (defun getf (plist tag &optional def)
635 "Search PROPLIST for property PROPNAME; return its value or DEFAULT. 636 "Search PROPLIST for property PROPNAME; return its value or DEFAULT.
636 PROPLIST is a list of the sort returned by `symbol-plist'." 637 PROPLIST is a list of the sort returned by `symbol-plist'."
637 (setplist '--cl-getf-symbol-- plist) 638 (setplist '--cl-getf-symbol-- plist)
681 (if (and (fboundp 'make-hashtable) (vectorp (make-hashtable 1))) 682 (if (and (fboundp 'make-hashtable) (vectorp (make-hashtable 1)))
682 (aref (make-hashtable 1) 0) (make-symbol "--cl-hash-tag--"))) 683 (aref (make-hashtable 1) 0) (make-symbol "--cl-hash-tag--")))
683 684
684 (defun hash-table-p (x) 685 (defun hash-table-p (x)
685 "Return t if OBJECT is a hash table." 686 "Return t if OBJECT is a hash table."
686 (or (eq (car-safe x) 'cl-hash-table-tag) 687 (or (and (fboundp 'hashtablep) (funcall 'hashtablep x))
687 (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag)) 688 (eq (car-safe x) 'cl-hash-table-tag)
688 (and (fboundp 'hashtablep) (funcall 'hashtablep x)))) 689 (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag))))
689 690
690 (defun cl-not-hash-table (x &optional y &rest z) 691 (defun cl-not-hash-table (x &optional y &rest z)
691 (signal 'wrong-type-argument (list 'hash-table-p (or y x)))) 692 (signal 'wrong-type-argument (list 'hash-table-p (or y x))))
692 693
693 (defun cl-hash-lookup (key table) 694 (defun cl-hash-lookup (key table)