Merge from emacs-24; up to 2014-07-26T11:58:24Z!schwab@linux-m68k.org

[gnu-emacs] / lisp / emacs-lisp / cl-extra.el

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 70ad1283cb213d14ecb7e05259a6448b9e625074..a7970261608c2a2fb352dee8ad231cefba83066e 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2000-2014 Free Software Foundation, Inc.
 
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Keywords: extensions
@@ -269,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
@@ -406,6 +383,42 @@ With two arguments, return rounding and remainder of their quotient."
   "Return 1 if X is positive, -1 if negative, 0 if zero."
   (cond ((> x 0) 1) ((< x 0) -1) (t 0)))
 
+;;;###autoload
+(cl-defun cl-parse-integer (string &key start end radix junk-allowed)
+  "Parse integer from the substring of STRING from START to END.
+STRING may be surrounded by whitespace chars (chars with syntax ` ').
+Other non-digit chars are considered junk.
+RADIX is an integer between 2 and 36, the default is 10.  Signal
+an error if the substring between START and END cannot be parsed
+as an integer unless JUNK-ALLOWED is non-nil."
+  (cl-check-type string string)
+  (let* ((start (or start 0))
+        (len   (length string))
+        (end   (or end len))
+        (radix (or radix 10)))
+    (or (<= start end len)
+       (error "Bad interval: [%d, %d)" start end))
+    (cl-flet ((skip-whitespace ()
+               (while (and (< start end)
+                           (= 32 (char-syntax (aref string start))))
+                 (setq start (1+ start)))))
+      (skip-whitespace)
+      (let ((sign (cl-case (and (< start end) (aref string start))
+                   (?+ (cl-incf start) +1)
+                   (?- (cl-incf start) -1)
+                   (t  +1)))
+           digit sum)
+       (while (and (< start end)
+                   (setq digit (cl-digit-char-p (aref string start) radix)))
+         (setq sum (+ (* (or sum 0) radix) digit)
+               start (1+ start)))
+       (skip-whitespace)
+       (cond ((and junk-allowed (null sum)) sum)
+             (junk-allowed (* sign sum))
+             ((or (/= start end) (null sum))
+              (error "Not an integer string: `%s'" string))
+             (t (* sign sum)))))))
+
 
 ;; Random numbers.
 
@@ -634,6 +647,13 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
        (progn (setplist sym (cdr (cdr plist))) t)
       (cl--do-remf plist tag))))
 
+;;; Streams.
+
+;;;###autoload
+(defun cl-fresh-line (&optional stream)
+  "Output a newline unless already at the beginning of a line."
+  (terpri stream 'ensure))
+
 ;;; Some debugging aids.
 
 (defun cl-prettyprint (form)