From: Tino Calancha <tino.calancha@gmail.com>
To: Emacs developers <emacs-devel@gnu.org>
Subject: Re: [PATCH v3] Bound index checks in cl-seq functions
Date: Sun, 05 Feb 2017 23:56:31 +0900 [thread overview]
Message-ID: <87o9ygadpc.fsf_-_@calancha-pc> (raw)
In-Reply-To: <87lgtlru13.fsf_-_@calancha-pc> (Tino Calancha's message of "Sun, 05 Feb 2017 16:11:52 +0900")
Tino Calancha <tino.calancha@gmail.com> writes:
I have updated the patch with following 3 dots.
(New patch below).
I) Fix mistake in previous patch:
(Following is a diff with respect patch #2)
diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index 314448ce93..e531fcb511 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -136,13 +136,13 @@ cl--check-bound-indices
(let* ((idx (match-string 2 (symbol-name (car cl-keys))))
(len (if (equal idx "2") len2 len1)))
(when (integerp (cadr cl-keys))
- (push (cons (car cl-keys) (cadr cl-keys)) alist))
+ (push (cons (car cl-keys) (cadr cl-keys)) alist)
(when (> (cadr cl-keys) len)
(error "Wrong bounding indices '%s', %s > (length %s), %s"
(substring (symbol-name (car cl-keys)) 1)
(cadr cl-keys)
(concat "cl-seq" idx)
- len))))
+ len)))))
II) Added test for `cl-delete-duplicates'.
III) Amend `edmacro-format-keys' to prevent `cl-mismatch' call
with :end1/:end2 > (length seq)
My goblins informed me after some tests at
test/lisp/kmacro-tests.el
started to fail. The new patch fix that.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
From 50ab342682911f343e70f58b5eb30b24981a783a Mon Sep 17 00:00:00 2001
From: Tino Calancha <tino.calancha@gmail.com>
Date: Sun, 5 Feb 2017 23:39:51 +0900
Subject: [PATCH 1/2] Check for out-of-range indices in cl-seq function
Throw and error if the user inputs out of range indices
or if :start value is higher than :end value.
* lisp/emacs-lisp/cl-seq.el (cl--parsing-keywords):
Check for negative indices.
(cl--check-bound-indices): New defun; check for indices > seq length,
or start index > end index.
(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.
* doc/misc/cl.texi (Sequence Basics): Update manual.
; * etc/NEWS: Announce the change.
* test/lisp/emacs-lisp/cl-seq-tests.el (cl-seq-check-bounds): New test.
---
doc/misc/cl.texi | 4 +-
etc/NEWS | 4 +
lisp/emacs-lisp/cl-seq.el | 355 +++++++++++++++++++++--------------
test/lisp/emacs-lisp/cl-seq-tests.el | 95 ++++++++++
4 files changed, 312 insertions(+), 146 deletions(-)
diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index 8baa0bd88c..6f387f5cbb 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -3247,7 +3247,9 @@ Sequence Basics
(exclusive) are affected by the operation. The @var{end} argument
may be passed @code{nil} to signify the length of the sequence;
otherwise, both @var{start} and @var{end} must be integers, with
-@code{0 <= @var{start} <= @var{end} <= (length @var{seq})}.
+@code{0 <= @var{start} <= @var{end} <= (length @var{seq})}. Emacs
+signals an error when this condition is not true, except for
+@code{cl-subseq} which allows negative indices.
If the function takes two sequence arguments, the limits are
defined by keywords @code{:start1} and @code{:end1} for the first,
and @code{:start2} and @code{:end2} for the second.
diff --git a/etc/NEWS b/etc/NEWS
index cbf2b70c82..b14f8eca5a 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -706,6 +706,10 @@ processes on exit.
* Incompatible Lisp Changes in Emacs 26.1
+++
+** CL sequence functions now throw errors when the input indices
+are out of range, or if :start index is higher than :end index.
+
++++
** Resizing a frame no longer runs 'window-configuration-change-hook'.
Put your function on 'window-size-change-functions' instead.
diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index 67ff1a00bd..e531fcb511 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
@@ -59,7 +60,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))
@@ -112,6 +119,49 @@ cl-test
(defvar cl-if) (defvar cl-if-not)
(defvar cl-key)
+;; Throw an error when :start or :end are > sequence length,
+;; or if :start > :end.
+;; If CL-SEQ2 is nil, then return (length cl-seq1), otherwise
+;; return (cons (length cl-seq1) (length cl-seq2)).
+(defun cl--check-bound-indices (cl-seq1 cl-seq2 cl-keys)
+ (let ((len1 (length cl-seq1))
+ (len2 (and cl-seq2 (length cl-seq2)))
+ (kwds (list :start1 :start2 :start :end1 :end2 :end))
+ alist)
+ (while cl-keys
+ (when (and (memq (car cl-keys) kwds)
+ (string-match ":\\(start\\|end\\)\\([1-2]?\\)\\'"
+ (symbol-name (car cl-keys))))
+ (delq (car cl-keys) kwds) ; Ignore succesive equal keys.
+ (let* ((idx (match-string 2 (symbol-name (car cl-keys))))
+ (len (if (equal idx "2") len2 len1)))
+ (when (integerp (cadr cl-keys))
+ (push (cons (car cl-keys) (cadr cl-keys)) alist)
+ (when (> (cadr cl-keys) len)
+ (error "Wrong bounding indices '%s', %s > (length %s), %s"
+ (substring (symbol-name (car cl-keys)) 1)
+ (cadr cl-keys)
+ (concat "cl-seq" idx)
+ len)))))
+ (setq cl-keys (cddr cl-keys)))
+ ;; Check :start value > :end value.
+ (mapc (lambda (x)
+ (and-let* ((start (alist-get (car x) alist))
+ (end (alist-get (cdr x) alist))
+ (bad-indices (> 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)))
+ ;; Return sequence lengths.
+ (if len2
+ (cons len1 len2)
+ len1)))
+
;;;###autoload
(defun cl-reduce (cl-func cl-seq &rest cl-keys)
"Reduce two-argument FUNCTION across SEQ.
@@ -128,6 +178,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)))
@@ -149,18 +200,19 @@ cl-fill
\nKeywords supported: :start :end
\n(fn SEQ ITEM [KEYWORD VALUE]...)"
(cl--parsing-keywords ((:start 0) :end) ()
- (if (listp cl-seq)
- (let ((p (nthcdr cl-start cl-seq))
- (n (and cl-end (- cl-end cl-start))))
- (while (and p (or (null n) (>= (cl-decf n) 0)))
- (setcar p cl-item)
- (setq p (cdr p))))
- (or cl-end (setq cl-end (length cl-seq)))
- (if (and (= cl-start 0) (= cl-end (length cl-seq)))
- (fillarray cl-seq cl-item)
- (while (< cl-start cl-end)
- (aset cl-seq cl-start cl-item)
- (setq cl-start (1+ cl-start)))))
+ (let ((len (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))))
+ (while (and p (or (null n) (>= (cl-decf n) 0)))
+ (setcar p cl-item)
+ (setq p (cdr p))))
+ (or cl-end (setq cl-end len))
+ (if (and (= cl-start 0) (= cl-end len))
+ (fillarray cl-seq cl-item)
+ (while (< cl-start cl-end)
+ (aset cl-seq cl-start cl-item)
+ (setq cl-start (1+ cl-start))))))
cl-seq))
;;;###autoload
@@ -170,44 +222,47 @@ cl-replace
\nKeywords supported: :start1 :end1 :start2 :end2
\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
(cl--parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
- (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
- (or (= cl-start1 cl-start2)
- (let* ((cl-len (length cl-seq1))
- (cl-n (min (- (or cl-end1 cl-len) cl-start1)
- (- (or cl-end2 cl-len) cl-start2))))
- (while (>= (setq cl-n (1- cl-n)) 0)
- (setf (elt cl-seq1 (+ cl-start1 cl-n))
- (elt cl-seq2 (+ cl-start2 cl-n))))))
- (if (listp cl-seq1)
- (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
- (cl-n1 (and cl-end1 (- cl-end1 cl-start1))))
- (if (listp cl-seq2)
- (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
- (cl-n (cond ((and cl-n1 cl-end2)
- (min cl-n1 (- cl-end2 cl-start2)))
- ((and cl-n1 (null cl-end2)) cl-n1)
- ((and (null cl-n1) cl-end2) (- cl-end2 cl-start2)))))
- (while (and cl-p1 cl-p2 (or (null cl-n) (>= (cl-decf cl-n) 0)))
- (setcar cl-p1 (car cl-p2))
- (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
- (setq cl-end2 (if (null cl-n1)
- (or cl-end2 (length cl-seq2))
- (min (or cl-end2 (length cl-seq2))
- (+ cl-start2 cl-n1))))
- (while (and cl-p1 (< cl-start2 cl-end2))
- (setcar cl-p1 (aref cl-seq2 cl-start2))
- (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
- (setq cl-end1 (min (or cl-end1 (length cl-seq1))
- (+ cl-start1 (- (or cl-end2 (length cl-seq2))
- cl-start2))))
- (if (listp cl-seq2)
- (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
- (while (< cl-start1 cl-end1)
- (aset cl-seq1 cl-start1 (car cl-p2))
- (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
- (while (< cl-start1 cl-end1)
- (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
- (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
+ (let* ((lens (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys))
+ (len1 (car lens))
+ (len2 (cdr lens)))
+ (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
+ (or (= cl-start1 cl-start2)
+ (let* ((cl-len len1)
+ (cl-n (min (- (or cl-end1 cl-len) cl-start1)
+ (- (or cl-end2 cl-len) cl-start2))))
+ (while (>= (setq cl-n (1- cl-n)) 0)
+ (setf (elt cl-seq1 (+ cl-start1 cl-n))
+ (elt cl-seq2 (+ cl-start2 cl-n))))))
+ (if (listp cl-seq1)
+ (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
+ (cl-n1 (and cl-end1 (- cl-end1 cl-start1))))
+ (if (listp cl-seq2)
+ (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
+ (cl-n (cond ((and cl-n1 cl-end2)
+ (min cl-n1 (- cl-end2 cl-start2)))
+ ((and cl-n1 (null cl-end2)) cl-n1)
+ ((and (null cl-n1) cl-end2) (- cl-end2 cl-start2)))))
+ (while (and cl-p1 cl-p2 (or (null cl-n) (>= (cl-decf cl-n) 0)))
+ (setcar cl-p1 (car cl-p2))
+ (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
+ (setq cl-end2 (if (null cl-n1)
+ (or cl-end2 len2)
+ (min (or cl-end2 len2)
+ (+ cl-start2 cl-n1))))
+ (while (and cl-p1 (< cl-start2 cl-end2))
+ (setcar cl-p1 (aref cl-seq2 cl-start2))
+ (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
+ (setq cl-end1 (min (or cl-end1 len1)
+ (+ cl-start1 (- (or cl-end2 len2)
+ cl-start2))))
+ (if (listp cl-seq2)
+ (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
+ (while (< cl-start1 cl-end1)
+ (aset cl-seq1 cl-start1 (car cl-p2))
+ (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
+ (while (< cl-start1 cl-end1)
+ (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
+ (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))))
cl-seq1))
;;;###autoload
@@ -219,7 +274,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) ()
- (let ((len (length cl-seq)))
+ (let ((len (cl--check-bound-indices cl-seq nil cl-keys)))
(if (<= (or cl-count (setq cl-count len)) 0)
cl-seq
(if (or (nlistp cl-seq) (and cl-from-end (< cl-count (/ len 2))))
@@ -283,7 +338,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) ()
- (let ((len (length cl-seq)))
+ (let ((len (cl--check-bound-indices cl-seq nil cl-keys)))
(if (<= (or cl-count (setq cl-count len)) 0)
cl-seq
(if (listp cl-seq)
@@ -356,39 +411,40 @@ cl--delete-duplicates
;; We need to parse :if, otherwise `cl-if' is unbound.
(:test :test-not :key (:start 0) :end :from-end :if)
()
- (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))
- (while (> cl-end 1)
- (setq cl-i 0)
- (while (setq cl-i (cl--position (cl--check-key (car cl-p))
- (cdr cl-p) cl-i (1- cl-end)))
- (if cl-copy (setq cl-seq (copy-sequence cl-seq)
- cl-p (nthcdr cl-start cl-seq) cl-copy nil))
- (let ((cl-tail (nthcdr cl-i cl-p)))
- (setcdr cl-tail (cdr (cdr cl-tail))))
- (setq cl-end (1- cl-end)))
- (setq cl-p (cdr cl-p) cl-end (1- cl-end)
- cl-start (1+ cl-start)))
- cl-seq)
- (setq cl-end (- (or cl-end (length cl-seq)) cl-start))
- (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
- (cl--position (cl--check-key (car cl-seq))
- (cdr cl-seq) 0 (1- cl-end)))
- (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
- (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
- (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
- (while (and (cdr (cdr cl-p)) (> cl-end 1))
- (if (cl--position (cl--check-key (car (cdr cl-p)))
- (cdr (cdr cl-p)) 0 (1- cl-end))
- (progn
- (if cl-copy (setq cl-seq (copy-sequence cl-seq)
- cl-p (nthcdr (1- cl-start) cl-seq)
- cl-copy nil))
- (setcdr cl-p (cdr (cdr cl-p))))
- (setq cl-p (cdr cl-p)))
- (setq cl-end (1- cl-end) cl-start (1+ cl-start)))
- cl-seq)))
+ (let ((len (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 len) cl-start))
+ (while (> cl-end 1)
+ (setq cl-i 0)
+ (while (setq cl-i (cl--position (cl--check-key (car cl-p))
+ (cdr cl-p) cl-i (1- cl-end)))
+ (if cl-copy (setq cl-seq (copy-sequence cl-seq)
+ cl-p (nthcdr cl-start cl-seq) cl-copy nil))
+ (let ((cl-tail (nthcdr cl-i cl-p)))
+ (setcdr cl-tail (cdr (cdr cl-tail))))
+ (setq cl-end (1- cl-end)))
+ (setq cl-p (cdr cl-p) cl-end (1- cl-end)
+ cl-start (1+ cl-start)))
+ cl-seq)
+ (setq cl-end (- (or cl-end len) cl-start))
+ (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1)
+ (cl--position (cl--check-key (car cl-seq))
+ (cdr cl-seq) 0 (1- cl-end)))
+ (setq cl-seq (cdr cl-seq) cl-end (1- cl-end)))
+ (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq)
+ (setq cl-end (1- cl-end) cl-start 1) cl-seq)))
+ (while (and (cdr (cdr cl-p)) (> cl-end 1))
+ (if (cl--position (cl--check-key (car (cdr cl-p)))
+ (cdr (cdr cl-p)) 0 (1- cl-end))
+ (progn
+ (if cl-copy (setq cl-seq (copy-sequence cl-seq)
+ cl-p (nthcdr (1- cl-start) cl-seq)
+ cl-copy nil))
+ (setcdr cl-p (cdr (cdr cl-p))))
+ (setq cl-p (cdr cl-p)))
+ (setq cl-end (1- cl-end) cl-start (1+ cl-start)))
+ cl-seq))))
(let ((cl-res (cl--delete-duplicates (append cl-seq nil) cl-keys nil)))
(if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))))
@@ -400,21 +456,22 @@ cl-substitute
\nKeywords supported: :test :test-not :key :count :start :end :from-end
\n(fn NEW OLD SEQ [KEYWORD VALUE]...)"
(cl--parsing-keywords (:test :test-not :key :if :if-not :count
- (:start 0) :end :from-end) ()
- (if (or (eq cl-old cl-new)
- (<= (or cl-count (setq cl-from-end nil
- cl-count (length cl-seq))) 0))
- cl-seq
- (let ((cl-i (cl--position cl-old cl-seq cl-start cl-end)))
- (if (not cl-i)
- cl-seq
- (setq cl-seq (copy-sequence cl-seq))
- (unless cl-from-end
- (setf (elt cl-seq cl-i) cl-new)
- (cl-incf cl-i)
- (cl-decf cl-count))
- (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count
- :start cl-i cl-keys))))))
+ (:start 0) :end :from-end) ()
+ (let ((len (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 len)) 0))
+ cl-seq
+ (let ((cl-i (cl--position cl-old cl-seq cl-start cl-end)))
+ (if (not cl-i)
+ cl-seq
+ (setq cl-seq (copy-sequence cl-seq))
+ (unless cl-from-end
+ (setf (elt cl-seq cl-i) cl-new)
+ (cl-incf cl-i)
+ (cl-decf cl-count))
+ (apply 'cl-nsubstitute cl-new cl-old cl-seq :count cl-count
+ :start cl-i cl-keys)))))))
;;;###autoload
(defun cl-substitute-if (cl-new cl-pred cl-list &rest cl-keys)
@@ -442,7 +499,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) ()
- (let ((len (length cl-seq)))
+ (let ((len (cl--check-bound-indices cl-seq nil cl-keys)))
(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))))
(let ((cl-p (nthcdr cl-start cl-seq)))
@@ -518,7 +575,8 @@ cl-position
\n(fn ITEM SEQ [KEYWORD VALUE]...)"
(cl--parsing-keywords (:test :test-not :key :if :if-not
(:start 0) :end :from-end) ()
- (cl--position cl-item cl-seq cl-start cl-end cl-from-end)))
+ (let ((len (cl--check-bound-indices cl-seq nil cl-keys)))
+ (cl--position cl-item cl-seq cl-start (or cl-end len) cl-from-end))))
(defun cl--position (cl-item cl-seq cl-start &optional cl-end cl-from-end)
(if (listp cl-seq)
@@ -562,8 +620,9 @@ 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) ()
- (let ((cl-count 0) cl-x)
- (or cl-end (setq cl-end (length cl-seq)))
+ (let ((len (cl--check-bound-indices cl-seq nil cl-keys))
+ (cl-count 0) cl-x)
+ (or cl-end (setq cl-end len))
(if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
(while (< cl-start cl-end)
(setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start)))
@@ -593,28 +652,31 @@ cl-mismatch
\nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
(cl--parsing-keywords (:test :test-not :key :from-end
- (:start1 0) :end1 (:start2 0) :end2) ()
- (or cl-end1 (setq cl-end1 (length cl-seq1)))
- (or cl-end2 (setq cl-end2 (length cl-seq2)))
- (if cl-from-end
- (progn
- (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
- (cl--check-match (elt cl-seq1 (1- cl-end1))
- (elt cl-seq2 (1- cl-end2))))
- (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
- (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
- (1- cl-end1)))
- (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
- (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
- (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
- (cl--check-match (if cl-p1 (car cl-p1)
- (aref cl-seq1 cl-start1))
- (if cl-p2 (car cl-p2)
- (aref cl-seq2 cl-start2))))
- (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
- cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
- (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
- cl-start1)))))
+ (:start1 0) :end1 (:start2 0) :end2) ()
+ (let* ((lens (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys))
+ (len1 (car lens))
+ (len2 (cdr lens)))
+ (or cl-end1 (setq cl-end1 len1))
+ (or cl-end2 (setq cl-end2 len2))
+ (if cl-from-end
+ (progn
+ (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
+ (cl--check-match (elt cl-seq1 (1- cl-end1))
+ (elt cl-seq2 (1- cl-end2))))
+ (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2)))
+ (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
+ (1- cl-end1)))
+ (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1)))
+ (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2))))
+ (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2)
+ (cl--check-match (if cl-p1 (car cl-p1)
+ (aref cl-seq1 cl-start1))
+ (if cl-p2 (car cl-p2)
+ (aref cl-seq2 cl-start2))))
+ (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)
+ cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2)))
+ (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
+ cl-start1))))))
;;;###autoload
(defun cl-search (cl-seq1 cl-seq2 &rest cl-keys)
@@ -624,24 +686,27 @@ cl-search
\nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end
\n(fn SEQ1 SEQ2 [KEYWORD VALUE]...)"
(cl--parsing-keywords (:test :test-not :key :from-end
- (:start1 0) :end1 (:start2 0) :end2) ()
- (or cl-end1 (setq cl-end1 (length cl-seq1)))
- (or cl-end2 (setq cl-end2 (length cl-seq2)))
- (if (>= cl-start1 cl-end1)
- (if cl-from-end cl-end2 cl-start2)
- (let* ((cl-len (- cl-end1 cl-start1))
- (cl-first (cl--check-key (elt cl-seq1 cl-start1)))
- (cl-if nil) cl-pos)
- (setq cl-end2 (- cl-end2 (1- cl-len)))
- (while (and (< cl-start2 cl-end2)
- (setq cl-pos (cl--position cl-first cl-seq2
- cl-start2 cl-end2 cl-from-end))
- (apply 'cl-mismatch cl-seq1 cl-seq2
- :start1 (1+ cl-start1) :end1 cl-end1
- :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
- :from-end nil cl-keys))
- (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
- (and (< cl-start2 cl-end2) cl-pos)))))
+ (:start1 0) :end1 (:start2 0) :end2) ()
+ (let* ((lens (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys))
+ (len1 (car lens))
+ (len2 (cdr lens)))
+ (or cl-end1 (setq cl-end1 len1))
+ (or cl-end2 (setq cl-end2 len2))
+ (if (>= cl-start1 cl-end1)
+ (if cl-from-end cl-end2 cl-start2)
+ (let* ((cl-len (- cl-end1 cl-start1))
+ (cl-first (cl--check-key (elt cl-seq1 cl-start1)))
+ (cl-if nil) cl-pos)
+ (setq cl-end2 (- cl-end2 (1- cl-len)))
+ (while (and (< cl-start2 cl-end2)
+ (setq cl-pos (cl--position cl-first cl-seq2
+ cl-start2 cl-end2 cl-from-end))
+ (apply 'cl-mismatch cl-seq1 cl-seq2
+ :start1 (1+ cl-start1) :end1 cl-end1
+ :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len)
+ :from-end nil cl-keys))
+ (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
+ (and (< cl-start2 cl-end2) cl-pos))))))
;;;###autoload
(defun cl-sort (cl-seq cl-pred &rest cl-keys)
diff --git a/test/lisp/emacs-lisp/cl-seq-tests.el b/test/lisp/emacs-lisp/cl-seq-tests.el
index 61e3d72033..9c6738048a 100644
--- a/test/lisp/emacs-lisp/cl-seq-tests.el
+++ b/test/lisp/emacs-lisp/cl-seq-tests.el
@@ -302,6 +302,101 @@ 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-delete-duplicates x :start 3)) . t)"
+ "((lambda (x y) (cl-delete-duplicates x :start 4)))"
+ "((lambda (x y) (cl-delete-duplicates x :start -1)))"
+ "((lambda (x y) (cl-delete-duplicates 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
From 72e9692cbc02150d9ef6c97011bdb55460686df4 Mon Sep 17 00:00:00 2001
From: Tino Calancha <tino.calancha@gmail.com>
Date: Sun, 5 Feb 2017 23:41:11 +0900
Subject: [PATCH 2/2] * lisp/edmacro.el (edmacro-format-keys): Prevent :end
index out-of-range.
---
lisp/edmacro.el | 7 ++++---
1 file changed, 4 insertions(+), 3 deletions(-)
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 5fefc3102d..c3608829c0 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -560,10 +560,11 @@ edmacro-format-keys
(if prefix
(setq desc (concat (edmacro-sanitize-for-string prefix) desc)))
(unless (string-match " " desc)
- (let ((times 1) (pos bind-len))
+ (let ((times 1) (pos bind-len)
+ (rest-mac-len (length rest-mac)))
(while (not (cl-mismatch rest-mac rest-mac
- :start1 0 :end1 bind-len
- :start2 pos :end2 (+ bind-len pos)))
+ :start1 0 :end1 (min bind-len rest-mac-len)
+ :start2 pos :end2 (min (+ bind-len pos) rest-mac-len)))
(cl-incf times)
(cl-incf pos bind-len))
(when (> times 1)
--
2.11.0
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
In GNU Emacs 26.0.50.1 (x86_64-pc-linux-gnu, GTK+ Version 3.22.7)
of 2017-02-05
Repository revision: 148100d98319499f0ac6f57b8be08cbd14884a5c
next prev parent reply other threads:[~2017-02-05 14:56 UTC|newest]
Thread overview: 14+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-02-04 16:40 [PATCH] Bound index checks in cl-seq functions Tino Calancha
2017-02-04 20:42 ` Philipp Stephani
2017-02-04 20:51 ` Noam Postavsky
2017-02-05 7:11 ` [PATCH v2] " Tino Calancha
2017-02-05 14:56 ` Tino Calancha [this message]
2017-02-05 16:11 ` Clément Pit-Claudel
2017-02-06 7:00 ` [PATCH v4] " Tino Calancha
2017-02-06 7:15 ` Clément Pit-Claudel
2017-02-10 7:43 ` Tino Calancha
2017-03-03 4:47 ` Tino Calancha
2017-03-03 13:52 ` Eli Zaretskii
2017-04-14 22:01 ` John Wiegley
2017-04-25 11:14 ` Tino Calancha
2017-02-12 21:26 ` [PATCH] " Johan Bockgård
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87o9ygadpc.fsf_-_@calancha-pc \
--to=tino.calancha@gmail.com \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).