Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 4800:b828e06dbe38

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
New (Common Lisp) function get-propertie
author Didier Verna <didier@xemacs.org>
date Wed, 06 Jan 2010 13:48:25 +0100
parents 95b04754ea8c
children 6ef8256a020a 8431b52e43b1
comparison
equal deleted inserted replaced
4798:ea7a6c12df45 4800:b828e06dbe38
101 (when (= cl-i (length cl-vector)) 101 (when (= cl-i (length cl-vector))
102 (while (and (>= (setq cl-i (1- cl-i)) 0) 102 (while (and (>= (setq cl-i (1- cl-i)) 0)
103 (or (eq (setq cl-char (aref cl-string cl-i)) 103 (or (eq (setq cl-char (aref cl-string cl-i))
104 (setq cl-other (aref cl-vector cl-i))) 104 (setq cl-other (aref cl-vector cl-i)))
105 (and (characterp cl-other) ; Note we want to call this 105 (and (characterp cl-other) ; Note we want to call this
106 ; as rarely as possible, it 106 ; as rarely as possible, it
107 ; doesn't have a bytecode. 107 ; doesn't have a bytecode.
108 (eq (downcase cl-char) (downcase cl-other)))))) 108 (eq (downcase cl-char) (downcase cl-other))))))
109 (< cl-i 0)))) 109 (< cl-i 0))))
110 110
111 ;; See comment on cl-string-vector-equalp above. 111 ;; See comment on cl-string-vector-equalp above.
112 (defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector) 112 (defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector)
116 (let ((cl-i (length cl-bit-vector)) 116 (let ((cl-i (length cl-bit-vector))
117 cl-other) 117 cl-other)
118 (when (= cl-i (length cl-vector)) 118 (when (= cl-i (length cl-vector))
119 (while (and (>= (setq cl-i (1- cl-i)) 0) 119 (while (and (>= (setq cl-i (1- cl-i)) 0)
120 (numberp (setq cl-other (aref cl-vector cl-i))) 120 (numberp (setq cl-other (aref cl-vector cl-i)))
121 ;; Differs from clisp here. 121 ;; Differs from clisp here.
122 (= (aref cl-bit-vector cl-i) cl-other))) 122 (= (aref cl-bit-vector cl-i) cl-other)))
123 (< cl-i 0)))) 123 (< cl-i 0))))
124 124
125 ;; These two helper functions call equalp recursively, the two above have no 125 ;; These two helper functions call equalp recursively, the two above have no
126 ;; need to. 126 ;; need to.
180 ((consp x) 180 ((consp x)
181 (while (and (consp x) (consp y) (equalp (car x) (car y))) 181 (while (and (consp x) (consp y) (equalp (car x) (car y)))
182 (setq x (cdr x) y (cdr y))) 182 (setq x (cdr x) y (cdr y)))
183 (and (not (consp x)) (equalp x y))) 183 (and (not (consp x)) (equalp x y)))
184 (t 184 (t
185 ;; From here on, the type tests don't (yet) have bytecodes. 185 ;; From here on, the type tests don't (yet) have bytecodes.
186 (let ((x-type (type-of x))) 186 (let ((x-type (type-of x)))
187 (cond ((eq 'vector x-type) 187 (cond ((eq 'vector x-type)
188 (if (stringp y) 188 (if (stringp y)
189 (cl-string-vector-equalp y x) 189 (cl-string-vector-equalp y x)
190 (if (vectorp y) 190 (if (vectorp y)
499 (while symbols 499 (while symbols
500 (setq symbol (car symbols) 500 (setq symbol (car symbols)
501 symbols (cdr symbols)) 501 symbols (cdr symbols))
502 (push `(make-obsolete ',(intern (format "%s*" symbol)) 502 (push `(make-obsolete ',(intern (format "%s*" symbol))
503 ',symbol "21.5.29") 503 ',symbol "21.5.29")
504 result) 504 result)
505 (push 505 (push
506 `(defun ,(intern (format "%s*" symbol)) (number &optional divisor) 506 `(defun ,(intern (format "%s*" symbol)) (number &optional divisor)
507 ,(format "See `%s'. This returns a list, not multiple values." 507 ,(format "See `%s'. This returns a list, not multiple values."
508 symbol) 508 symbol)
509 (multiple-value-list (,symbol number divisor))) 509 (multiple-value-list (,symbol number divisor)))
696 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) 696 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
697 697
698 ;; XEmacs change: we have a builtin remprop 698 ;; XEmacs change: we have a builtin remprop
699 (defalias 'cl-remprop 'remprop) 699 (defalias 'cl-remprop 'remprop)
700 700
701 (defun get-properties (plist indicator-list)
702 "Find a property from INDICATOR-LIST in PLIST.
703 Return 3 values:
704 - the first property found,
705 - its value,
706 - the tail of PLIST beginning with the found entry."
707 (do ((plst plist (cddr plst)))
708 ((null plst) (values nil nil nil))
709 (cond ((atom (cdr plst))
710 (error "Malformed property list: %S." plist))
711 ((memq (car plst) indicator-list)
712 (return (values (car plst) (cadr plst) plst))))))
701 713
702 714
703 ;;; Hash tables. 715 ;;; Hash tables.
704 716
705 ;; The `regular' Common Lisp hash-table stuff has been moved into C. 717 ;; The `regular' Common Lisp hash-table stuff has been moved into C.
762 (cl-do-prettyprint))) 774 (cl-do-prettyprint)))
763 775
764 (defun cl-do-prettyprint () 776 (defun cl-do-prettyprint ()
765 (skip-chars-forward " ") 777 (skip-chars-forward " ")
766 (if (looking-at "(") 778 (if (looking-at "(")
767 (let ((skip (or (looking-at "((") 779 (let ((skip (or (looking-at "((")
768 ;; XEmacs: be selective about trailing stuff after prog 780 ;; XEmacs: be selective about trailing stuff after prog
769 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]") 781 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]")
770 (looking-at "(unwind-protect ") 782 (looking-at "(unwind-protect ")
771 (looking-at "(function (") 783 (looking-at "(function (")
772 (looking-at "(cl-block-wrapper "))) 784 (looking-at "(cl-block-wrapper ")))