[PATCH] Bound index checks in cl-seq functions

[Tino Calancha <tino.calancha@gmail.com>]

Consider following evaluations:

(cl-position 2 (list 1 2 3) :start -999)
=> -998
(cl-position 2 (list 1 2 3) :start 999)
=> nil
(cl-position 2 (list 1 2 3) :start 1 :end 0)
=> nil

*) In the first two, the indices are out of range.
*) In the 3rd, the start index is higher than the end index.

Guy L. Steele recommends to throw an error in those cases:
http://www.lispworks.com/documentation/HyperSpec/Issues/iss332_w.htm

We have partially done the job, at least for `cl-subseq':
(cl-subseq (list 1 2 3) 999)
; Signal: "Bad bounding indices: 999, nil"

(cl-subseq (list 1 2 3) -999)
; Signal: "Bad bounding indices: -999, nil"

(cl-subseq (list 1 2 3) -1)
=> (3) ; This is OK as documented in the docstring.

See:
https://lists.gnu.org/archive/html/emacs-devel/2015-08/msg00182.html

It would be nice if all the sequence functions in cl-seq.el
throw errors in those situations.

What do you think?
The following patch implements such bounding checks for the indices.
Comments are very welcome.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
From c076a16716d6b9ad5c971d67375223974df53a40 Mon Sep 17 00:00:00 2001
From: Tino Calancha <tino.calancha@gmail.com>
Date: Sat, 4 Feb 2017 21:53:48 +0900
Subject: [PATCH 1/3] cl--parsing-keywords: Check for negative indices

* lisp/emacs-lisp/cl-seq.el (cl--parsing-keywords):
Throw and error when the user inputs a negative index for the sequence.
---
 lisp/emacs-lisp/cl-seq.el | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index 67ff1a00bd..558adf22fe 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -59,7 +59,13 @@ cl--parsing-keywords
                    (setq mem `(and ,mem (setq cl-if ,mem) t)))
                (list (intern
                       (format "cl-%s" (substring (symbol-name var) 1)))
-                     (if (consp x) `(or ,mem ,(car (cdr x))) mem))))
+                     `(if (and (string-match ":\\(start\\|end\\)" (symbol-name ,var))
+                               (integerp (or ,mem ,(car (cdr-safe x))))
+                               (not (natnump (or ,mem ,(car (cdr-safe x))))))
+                          (error "Wrong negative index '%s': natnump, %s"
+                                 (substring (symbol-name ,var) 1)
+                                 (or ,mem ,(car (cdr-safe x))))
+                        (or ,mem ,(car (cdr-safe x)))))))
            kwords)
      ,@(append
         (and (not (eq other-keys t))
-- 
2.11.0

From 9898718b96109c5815b81f8dc8868de4d86db453 Mon Sep 17 00:00:00 2001
From: Tino Calancha <tino.calancha@gmail.com>
Date: Sun, 5 Feb 2017 00:04:12 +0900
Subject: [PATCH 2/3] cl--check-bound-indices: Check for unbound indices

Throw and error if the user inputs an index higher than the sequence length
or if :start value is higher than :end value.
* lisp/emacs-lisp/cl-seq.el (cl--check-bound-indices): New defun.
(cl-reduce, cl-fill, cl-replace, cl-remove, cl-delete)
(cl--delete-duplicates, cl-substitute, cl-nsubstitute, cl-position)
(cl-count, cl-mismatch, cl-search): Use it.
---
 lisp/emacs-lisp/cl-seq.el | 51 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 51 insertions(+)

diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index 558adf22fe..0cb7ac7bdd 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -42,6 +42,7 @@
 ;;; Code:
 
 (require 'cl-lib)
+(eval-when-compile (require 'subr-x))
 
 ;; Keyword parsing.
 ;; This is special-cased here so that we can compile
@@ -118,6 +119,44 @@ cl-test
 (defvar cl-if) (defvar cl-if-not)
 (defvar cl-key)
 
+;; Throw an error when :start or :end are > sequence length.
+(defmacro cl--check-bound-indices (cl-seq1 cl-seq2 cl-keys)
+  (declare (debug t))
+  `(let ((len1 (length ,cl-seq1))
+         (len2 (and ,cl-seq2 (length ,cl-seq2)))
+         (kwds (list :start1 :start2 :start :end1 :end2 :end))
+         (keys ,cl-keys)
+         alist)
+     (while keys
+       (when (and (memq (car keys) kwds)
+                  (string-match ":\\(start\\|end\\)\\([1-2]?\\)\\'"
+                                (symbol-name (car keys))))
+         (delq (car keys) kwds) ; Ignore succesive equal keys.
+         (let* ((idx (match-string 2 (symbol-name (car keys))))
+                (len (if (equal idx "2") len2 len1)))
+           (when (integerp (cadr keys))
+             (push (cons (car keys) (cadr keys)) alist))
+           (when (> (cadr keys) len)
+             (error "Wrong bounding indices '%s', %s > (length %s), %s"
+                    (substring (symbol-name (car keys)) 1)
+                    (cadr keys)
+                    (concat "cl-seq" idx)
+                    len))))
+       (setq keys (cddr keys)))
+     ;; Check :start value > :end value.
+     (mapc (lambda (x)
+             (and-let* ((start (alist-get (car x) alist))
+                        (end (alist-get (cdr x) alist)))
+               (when (> start end)
+                 (error "Bad bounding indices '%s', '%s': %d, %d"
+                        (substring (symbol-name (car x)) 1)
+                        (substring (symbol-name (cdr x)) 1)
+                        start
+                        end))))
+           (list (cons :start :end)
+                 (cons :start1 :end1)
+                 (cons :start2 :end2)))))
+
 ;;;###autoload
 (defun cl-reduce (cl-func cl-seq &rest cl-keys)
   "Reduce two-argument FUNCTION across SEQ.
@@ -134,6 +173,7 @@ cl-reduce
 
 \n(fn FUNCTION SEQ [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) ()
+    (cl--check-bound-indices cl-seq nil cl-keys)
     (or (listp cl-seq) (setq cl-seq (append cl-seq nil)))
     (setq cl-seq (cl-subseq cl-seq cl-start cl-end))
     (if cl-from-end (setq cl-seq (nreverse cl-seq)))
@@ -155,6 +195,7 @@ cl-fill
 \nKeywords supported:  :start :end
 \n(fn SEQ ITEM [KEYWORD VALUE]...)"
   (cl--parsing-keywords ((:start 0) :end) ()
+    (cl--check-bound-indices cl-seq nil cl-keys)
     (if (listp cl-seq)
 	(let ((p (nthcdr cl-start cl-seq))
 	      (n (and cl-end (- cl-end cl-start))))
@@ -176,6 +217,7 @@ cl-replace
 \nKeywords supported:  :start1 :end1 :start2 :end2
 \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
   (cl--parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
+    (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys)
     (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
 	(or (= cl-start1 cl-start2)
 	    (let* ((cl-len (length cl-seq1))
@@ -225,6 +267,7 @@ cl-remove
 \n(fn ITEM SEQ [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end
 			(:start 0) :end) ()
+    (cl--check-bound-indices cl-seq nil cl-keys)
     (let ((len (length cl-seq)))
       (if (<= (or cl-count (setq cl-count len)) 0)
 	cl-seq
@@ -289,6 +332,7 @@ cl-delete
 \n(fn ITEM SEQ [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:test :test-not :key :if :if-not :count :from-end
 			(:start 0) :end) ()
+    (cl--check-bound-indices cl-seq nil cl-keys)
     (let ((len (length cl-seq)))
       (if (<= (or cl-count (setq cl-count len)) 0)
 	cl-seq
@@ -362,6 +406,7 @@ cl--delete-duplicates
           ;; We need to parse :if, otherwise `cl-if' is unbound.
           (:test :test-not :key (:start 0) :end :from-end :if)
 	  ()
+        (cl--check-bound-indices cl-seq nil cl-keys)
 	(if cl-from-end
 	    (let ((cl-p (nthcdr cl-start cl-seq)) cl-i)
 	      (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
@@ -407,6 +452,7 @@ cl-substitute
 \n(fn NEW OLD SEQ [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:test :test-not :key :if :if-not :count
 			(:start 0) :end :from-end) ()
+    (cl--check-bound-indices cl-seq nil cl-keys)
     (if (or (eq cl-old cl-new)
 	    (<= (or cl-count (setq cl-from-end nil
 				   cl-count (length cl-seq))) 0))
@@ -448,6 +494,7 @@ cl-nsubstitute
 \n(fn NEW OLD SEQ [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:test :test-not :key :if :if-not :count
 			(:start 0) :end :from-end) ()
+    (cl--check-bound-indices cl-seq nil cl-keys)
     (let ((len (length cl-seq)))
       (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count len)) 0)
 	  (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count (/ len 2))))
@@ -524,6 +571,7 @@ cl-position
 \n(fn ITEM SEQ [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:test :test-not :key :if :if-not
 			(:start 0) :end :from-end) ()
+    (cl--check-bound-indices cl-seq nil cl-keys)
     (cl--position cl-item cl-seq cl-start cl-end cl-from-end)))
 
 (defun cl--position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
@@ -568,6 +616,7 @@ cl-count
 \nKeywords supported:  :test :test-not :key :start :end
 \n(fn ITEM SEQ [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) ()
+    (cl--check-bound-indices cl-seq nil cl-keys)
     (let ((cl-count 0) cl-x)
       (or cl-end (setq cl-end (length cl-seq)))
       (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
@@ -600,6 +649,7 @@ cl-mismatch
 \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:test :test-not :key :from-end
 			(:start1 0) :end1 (:start2 0) :end2) ()
+    (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys)
     (or cl-end1 (setq cl-end1 (length cl-seq1)))
     (or cl-end2 (setq cl-end2 (length cl-seq2)))
     (if cl-from-end
@@ -631,6 +681,7 @@ cl-search
 \n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
   (cl--parsing-keywords (:test :test-not :key :from-end
 			(:start1 0) :end1 (:start2 0) :end2) ()
+    (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys)
     (or cl-end1 (setq cl-end1 (length cl-seq1)))
     (or cl-end2 (setq cl-end2 (length cl-seq2)))
     (if (>= cl-start1 cl-end1)
-- 
2.11.0

From 50cce9d03fa96d622d20f2218ec5ddcfeb246425 Mon Sep 17 00:00:00 2001
From: Tino Calancha <tino.calancha@gmail.com>
Date: Sun, 5 Feb 2017 01:06:01 +0900
Subject: [PATCH 3/3] * test/lisp/emacs-lisp/cl-seq-tests.el
 (cl-seq-check-bounds): New test.

---
 test/lisp/emacs-lisp/cl-seq-tests.el | 91 ++++++++++++++++++++++++++++++++++++
 1 file changed, 91 insertions(+)

diff --git a/test/lisp/emacs-lisp/cl-seq-tests.el b/test/lisp/emacs-lisp/cl-seq-tests.el
index 61e3d72033..f5ecfe4b92 100644
--- a/test/lisp/emacs-lisp/cl-seq-tests.el
+++ b/test/lisp/emacs-lisp/cl-seq-tests.el
@@ -294,6 +294,7 @@ cl-seq--with-side-effects
 
 (ert-deftest cl-seq-test-bug24264 ()
   "Test for http://debbugs.gnu.org/24264 ."
+  :tags '(:expensive-test)
   (let ((list  (append (make-list 8000005 1) '(8)))
         (list2 (make-list 8000005 2)))
     (should (cl-position 8 list))
@@ -302,6 +303,96 @@ cl-seq--with-side-effects
     (should (equal '(2 8) (last (cl-replace list list2) 2)))
     (should (equal '(1 1) (last (cl-fill list 1) 2)))))
 
+(ert-deftest cl-seq-check-bounds ()
+  (let ((lst (list 1 2 3))
+        (lst2 (list 'a 'b 'c))
+        ;; t means pass, nil means fails.
+        (tests '("((lambda (x y) (cl-reduce #'max x :start 1)) . t)"
+                 "((lambda (x y) (cl-reduce #'max x :start -1)))"
+                 "((lambda (x y) (cl-reduce #'max x :start 4)))"
+                 "((lambda (x y) (cl-reduce #'max x :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-fill x 'b :start 3)) . t)"
+                 "((lambda (x y) (cl-fill x 'b :start 4)))"
+                 "((lambda (x y) (cl-fill x 'b :start -1)))"
+                 "((lambda (x y) (cl-fill x 'b :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-replace x y :start1 3)) . t)"
+                 "((lambda (x y) (cl-replace x y :start2 3)) . t)"
+                 "((lambda (x y) (cl-replace x y :start1 4)))"
+                 "((lambda (x y) (cl-replace x y :start2 4)))"
+                 "((lambda (x y) (cl-replace x y :start1 -1)))"
+                 "((lambda (x y) (cl-replace x y :start2 -1)))"
+                 "((lambda (x y) (cl-replace x y :start1 2 :end1 1)))"
+                 "((lambda (x y) (cl-replace x y :start2 2 :end2 1)))"
+                 ;;
+                 "((lambda (x y) (cl-remove nil x :start 3)) . t)"
+                 "((lambda (x y) (cl-remove nil x :start 4)))"
+                 "((lambda (x y) (cl-remove nil x :start -1)))"
+                 "((lambda (x y) (cl-remove nil x :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-delete nil x :start 3)) . t)"
+                 "((lambda (x y) (cl-delete nil x :start 4)))"
+                 "((lambda (x y) (cl-delete nil x :start -1)))"
+                 "((lambda (x y) (cl-delete nil x :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-remove-duplicates x :start 3)) . t)"
+                 "((lambda (x y) (cl-remove-duplicates x :start 4)))"
+                 "((lambda (x y) (cl-remove-duplicates x :start -1)))"
+                 "((lambda (x y) (cl-remove-duplicates x :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-substitute 'foo 2 x :start 3)) . t)"
+                 "((lambda (x y) (cl-substitute 'foo 2 x :start 4)))"
+                 "((lambda (x y) (cl-substitute 'foo 2 x :start -1)))"
+                 "((lambda (x y) (cl-substitute 'foo 2 x :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-nsubstitute 'foo 2 x :start 3)) . t)"
+                 "((lambda (x y) (cl-nsubstitute 'foo 2 x :start 4)))"
+                 "((lambda (x y) (cl-nsubstitute 'foo 2 x :start -1)))"
+                 "((lambda (x y) (cl-nsubstitute 'foo 2 x :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-position 2 x :start 4)))"
+                 "((lambda (x y) (cl-position 2 x :start -1)))"
+                 "((lambda (x y) (cl-position 2 x :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-count 2 x :start 3)) . t)"
+                 "((lambda (x y) (cl-count 2 x :start 4)))"
+                 "((lambda (x y) (cl-count 2 x :start -1)))"
+                 "((lambda (x y) (cl-count 2 x :start 2 :end 1)))"
+                 ;;
+                 "((lambda (x y) (cl-mismatch x x :start1 1 :start2 3)) . t)"
+                 "((lambda (x y) (cl-mismatch x x :start1 1 :start2 4)))"
+                 "((lambda (x y) (cl-mismatch x x :start1 4 :start2 1)))"
+                 "((lambda (x y) (cl-mismatch x x :start1 -1 :start2 1)))"
+                 "((lambda (x y) (cl-mismatch x x :start1 1 :start2 -1)))"
+                 "((lambda (x y) (cl-mismatch x x :start1 2 :end1 1)))"
+                 "((lambda (x y) (cl-mismatch x x :start2 2 :end2 1)))"
+                 ;;
+                 "((lambda (x y) (cl-search x x :start1 3 :start2 3)) . t)"
+                 "((lambda (x y) (cl-search x x :start1 4 :start2 4)))"
+                 "((lambda (x y) (cl-search x x :start1 -1 :start2 3)))"
+                 "((lambda (x y) (cl-search x x :start1 1 :start2 -1)))"
+                 "((lambda (x y) (cl-search x x :start1 2 :end1 1)))"
+                 "((lambda (x y) (cl-search x x :start2 2 :end2 1)))"
+                 ;;
+                 "((lambda (x y) (cl-subseq x -1)) . t)"
+                 "((lambda (x y) (cl-subseq x -2 -1)) . t)"
+                 "((lambda (x y) (cl-subseq x -4)))"
+                 "((lambda (x y) (cl-subseq x 2 1)))")))
+    (dolist (limit '("start" "end"))
+      (dolist (x tests)
+        (let ((form
+               (car
+                (read-from-string
+                 (cond ((string-match ":start\\([1-2]?\\) \\([0-9-]+\\) :end\\([1-2]?\\)" x)
+                        x)
+                       ((string= limit "start") x)
+                       (t
+                        (replace-regexp-in-string "start" limit x)))))))
+          (if (cdr form)
+              (should (funcall (car form) lst lst2))
+            (should-error (funcall (car form) lst lst2))))))))
+
 
 (provide 'cl-seq-tests)
 ;;; cl-seq-tests.el ends here
-- 
2.11.0

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
In GNU Emacs 26.0.50.1 (x86_64-pc-linux-gnu, GTK+ Version 3.22.7)
 of 2017-02-04
Repository revision: ff4dd0d39c3f5dfb8f4988f840c2c05621db32db