lisp/emacs-lisp/cl-extra.el (cl--map-overlays): Remove obsolete code.

[bpt/emacs.git] / lisp / emacs-lisp / cl-extra.el

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 7c25972..3761d04 100644 (file)
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -1,6 +1,6 @@
 ;;; cl-extra.el --- Common Lisp features, part 2  -*- lexical-binding: t -*-
 
-;; Copyright (C) 1993, 2000-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2000-2014 Free Software Foundation, Inc.
 
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Keywords: extensions
@@ -51,7 +51,8 @@ TYPE is a Common Lisp type specifier.
        ((eq type 'string) (if (stringp x) x (concat x)))
        ((eq type 'array) (if (arrayp x) x (vconcat x)))
        ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
-       ((and (eq type 'character) (symbolp x)) (cl-coerce (symbol-name x) type))
+       ((and (eq type 'character) (symbolp x))
+         (cl-coerce (symbol-name x) type))
        ((eq type 'float) (float x))
        ((cl-typep x type) x)
        (t (error "Can't coerce %s to type %s" x type))))
@@ -69,7 +70,7 @@ strings case-insensitively."
        ((stringp x)
         (and (stringp y) (= (length x) (length y))
              (or (string-equal x y)
-                 (string-equal (downcase x) (downcase y)))))   ; lazy but simple!
+                 (string-equal (downcase x) (downcase y))))) ;Lazy but simple!
        ((numberp x)
         (and (numberp y) (= x y)))
        ((consp x)
@@ -268,43 +269,20 @@ If so, return the true (non-nil) value returned by PREDICATE.
 ;;;###autoload
 (defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
   (or cl-buffer (setq cl-buffer (current-buffer)))
-  (if (fboundp 'overlay-lists)
-
-      ;; This is the preferred algorithm, though overlay-lists is undocumented.
-      (let (cl-ovl)
-       (with-current-buffer cl-buffer
-         (setq cl-ovl (overlay-lists))
-         (if cl-start (setq cl-start (copy-marker cl-start)))
-         (if cl-end (setq cl-end (copy-marker cl-end))))
-       (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
-       (while (and cl-ovl
-                   (or (not (overlay-start (car cl-ovl)))
-                       (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
-                       (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
-                       (not (funcall cl-func (car cl-ovl) cl-arg))))
-         (setq cl-ovl (cdr cl-ovl)))
-       (if cl-start (set-marker cl-start nil))
-       (if cl-end (set-marker cl-end nil)))
-
-    ;; This alternate algorithm fails to find zero-length overlays.
-    (let ((cl-mark (with-current-buffer cl-buffer
-                    (copy-marker (or cl-start (point-min)))))
-         (cl-mark2 (and cl-end (with-current-buffer cl-buffer
-                                 (copy-marker cl-end))))
-         cl-pos cl-ovl)
-      (while (save-excursion
-              (and (setq cl-pos (marker-position cl-mark))
-                   (< cl-pos (or cl-mark2 (point-max)))
-                   (progn
-                     (set-buffer cl-buffer)
-                     (setq cl-ovl (overlays-at cl-pos))
-                     (set-marker cl-mark (next-overlay-change cl-pos)))))
-       (while (and cl-ovl
-                   (or (/= (overlay-start (car cl-ovl)) cl-pos)
-                       (not (and (funcall cl-func (car cl-ovl) cl-arg)
-                                 (set-marker cl-mark nil)))))
-         (setq cl-ovl (cdr cl-ovl))))
-      (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
+  (let (cl-ovl)
+    (with-current-buffer cl-buffer
+      (setq cl-ovl (overlay-lists))
+      (if cl-start (setq cl-start (copy-marker cl-start)))
+      (if cl-end (setq cl-end (copy-marker cl-end))))
+    (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
+    (while (and cl-ovl
+               (or (not (overlay-start (car cl-ovl)))
+                   (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
+                   (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
+                   (not (funcall cl-func (car cl-ovl) cl-arg))))
+      (setq cl-ovl (cdr cl-ovl)))
+    (if cl-start (set-marker cl-start nil))
+    (if cl-end (set-marker cl-end nil))))
 
 ;;; Support for `setf'.
 ;;;###autoload
@@ -439,14 +417,14 @@ Optional second arg STATE is a random-state object."
 If STATE is t, return a new state object seeded from the time of day."
   (cond ((null state) (cl-make-random-state cl--random-state))
        ((vectorp state) (copy-tree state t))
-       ((integerp state) (vector 'cl-random-state-tag -1 30 state))
+       ((integerp state) (vector 'cl--random-state-tag -1 30 state))
        (t (cl-make-random-state (cl--random-time)))))
 
 ;;;###autoload
 (defun cl-random-state-p (object)
   "Return t if OBJECT is a random-state object."
   (and (vectorp object) (= (length object) 4)
-       (eq (aref object 0) 'cl-random-state-tag)))
+       (eq (aref object 0) 'cl--random-state-tag)))
 
 
 ;; Implementation limits.
@@ -596,8 +574,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
                   (macroexp-let2 nil d def
                     (funcall do `(cl-getf ,getter ,k ,d)
                              (lambda (v)
-                               (funcall setter
-                                        `(cl--set-getf ,getter ,k ,v))))))))))
+                               (macroexp-let2 nil val v
+                                 `(progn
+                                    ,(funcall setter
+                                              `(cl--set-getf ,getter ,k ,val))
+                                    ,val))))))))))
   (setplist '--cl-getf-symbol-- plist)
   (or (get '--cl-getf-symbol-- tag)
       ;; Originally we called cl-get here,