Fix seq-subseq and cl-subseq for bad bounding indices

[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 3761d04c2c2ff06ec6e4b47e26d171054964bbf9..afc2adbee6d4641fec8656199c6debaae7959860 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-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2000-2015 Free Software Foundation, Inc.
 
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Keywords: extensions
@@ -38,6 +38,7 @@
 ;;; Code:
 
 (require 'cl-lib)
+(require 'seq)
 
 ;;; Type coercion.
 
@@ -383,6 +384,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.
 
@@ -485,28 +522,10 @@ If END is omitted, it defaults to the length of the sequence.
 If START or END is negative, it counts from the end."
   (declare (gv-setter
             (lambda (new)
-              `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
-                      ,new))))
-  (if (stringp seq) (substring seq start end)
-    (let (len)
-      (and end (< end 0) (setq end (+ end (setq len (length seq)))))
-      (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
-      (cond ((listp seq)
-            (if (> start 0) (setq seq (nthcdr start seq)))
-            (if end
-                (let ((res nil))
-                  (while (>= (setq end (1- end)) start)
-                    (push (pop seq) res))
-                  (nreverse res))
-              (copy-sequence seq)))
-           (t
-            (or end (setq end (or len (length seq))))
-            (let ((res (make-vector (max (- end start) 0) nil))
-                  (i 0))
-              (while (< start end)
-                (aset res i (aref seq start))
-                (setq i (1+ i) start (1+ start)))
-              res))))))
+              (macroexp-let2 nil new new
+               `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
+                       ,new)))))
+  (seq-subseq seq start end))
 
 ;;;###autoload
 (defun cl-concatenate (type &rest seqs)
@@ -552,7 +571,7 @@ If START or END is negative, it counts from the end."
   "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
 \n(fn SYMBOL PROPNAME &optional DEFAULT)"
   (declare (compiler-macro cl--compiler-macro-get)
-           (gv-setter (lambda (store) `(put ,sym ,tag ,store))))
+           (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store))))
   (or (get sym tag)
       (and def
            ;; Make sure `def' is really absent as opposed to set to nil.
@@ -570,15 +589,14 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
   (declare (gv-expander
             (lambda (do)
               (gv-letplace (getter setter) plist
-                (macroexp-let2 nil k tag
-                  (macroexp-let2 nil d def
-                    (funcall do `(cl-getf ,getter ,k ,d)
-                             (lambda (v)
-                               (macroexp-let2 nil val v
-                                 `(progn
-                                    ,(funcall setter
-                                              `(cl--set-getf ,getter ,k ,val))
-                                    ,val))))))))))
+                (macroexp-let2* nil ((k tag) (d def))
+                  (funcall do `(cl-getf ,getter ,k ,d)
+                          (lambda (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,
@@ -611,6 +629,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)
@@ -677,4 +702,5 @@ including `cl-block' and `cl-eval-when'."
 ;; generated-autoload-file: "cl-loaddefs.el"
 ;; End:
 
+(provide 'cl-extra)
 ;;; cl-extra.el ends here