From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Tino Calancha Newsgroups: gmane.emacs.devel Subject: [PATCH] Bound index checks in cl-seq functions Date: Sun, 05 Feb 2017 01:40:44 +0900 Message-ID: <87efzdrjsj.fsf@calancha-pc> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1486226495 29374 195.159.176.226 (4 Feb 2017 16:41:35 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Sat, 4 Feb 2017 16:41:35 +0000 (UTC) Cc: tino.calancha@gmail.com To: Emacs developers Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Sat Feb 04 17:41:30 2017 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ca3P0-0007Qo-BM for ged-emacs-devel@m.gmane.org; Sat, 04 Feb 2017 17:41:30 +0100 Original-Received: from localhost ([::1]:39933 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ca3P5-0007GL-P1 for ged-emacs-devel@m.gmane.org; Sat, 04 Feb 2017 11:41:35 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:33052) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ca3OS-0007GC-Mg for emacs-devel@gnu.org; Sat, 04 Feb 2017 11:40:58 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ca3ON-0001Ym-Vh for emacs-devel@gnu.org; Sat, 04 Feb 2017 11:40:56 -0500 Original-Received: from mail-pg0-x243.google.com ([2607:f8b0:400e:c05::243]:35842) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1ca3ON-0001YB-MM for emacs-devel@gnu.org; Sat, 04 Feb 2017 11:40:51 -0500 Original-Received: by mail-pg0-x243.google.com with SMTP id 75so4787064pgf.3 for ; Sat, 04 Feb 2017 08:40:51 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:date:message-id:mime-version; bh=uEinEwZuTwnaA2HasBnKPyZEzpTEx4FdRNiFaivQBg0=; b=PBoUVyqsAIDUDkU5szj0E56KntZhL2v7qVueX7RFj/FZFijEjC6uX9M4GFnuWlRhRR rV7J1WQy8vmdeTlDdMoK7JitsFuOk+58oBVgnDkaV3BkYUeWgUKNGfBpMGHyy25+RW15 9m5rgSIMASYyPNBKg2Mg4DU0+VhZ7YBhjG/lFpeZpdbyGrZ+HSrlNO2GEvq3I32UNTHn 6gMa9xrU2tPHTuLpwLlLj3P92mskBDdnfC3vcrnb/2FKc01Q6rWH1SnQUoKQ8WeM4Wpc tF7uUdoiWyuqHPZ1uOLOtUS/35YmavTD94fN8B2Bt9Yfm6rskTNWNJqVTCqph/7gUaMN dB5w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:date:message-id:mime-version; bh=uEinEwZuTwnaA2HasBnKPyZEzpTEx4FdRNiFaivQBg0=; b=LB/tOaHT3lSc5ZVTySH0aFqsgGW1PsDpZFl87Xp5YSz73GaltX7Ym8CBDZ+/QRJ7Rh ZcdcUN+liWL3aXPM1gQsuNHcrxwkA2wnCx2xxwAEcSuo7V62Uts18FMwfdDUX40TYLxd tb4S6WKUweERiiC/ZNS7+CRByLGT8cDD4693xQ4VA2zkNyBoHKRZJqLj/4qE5ePbnNRo o2n7NsyeVY2cnxcB2kQv19iGsuh3Jl8W1A6zLiaURuClwxe+NUwmpcF6+dKnfUtL0/x9 nno4oDyRJQADypwUqrx5bPpvI0Wh0WtVSLQoVuqFE8rZ2TQpp7HHNmV4dYq6Ne+WoYFu 7ntw== X-Gm-Message-State: AIkVDXJ4rWDpnwctaVf3G7rEi6BHTkZVikqLxA+oFwuNT7faSyXk3TU/3FNPeS4VABHxRQ== X-Received: by 10.98.26.210 with SMTP id a201mr3546094pfa.57.1486226450600; Sat, 04 Feb 2017 08:40:50 -0800 (PST) Original-Received: from calancha-pc (104.81.147.124.dy.bbexcite.jp. [124.147.81.104]) by smtp.gmail.com with ESMTPSA id n70sm76391232pfg.34.2017.02.04.08.40.48 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Sat, 04 Feb 2017 08:40:50 -0800 (PST) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2607:f8b0:400e:c05::243 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:211961 Archived-At: 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 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 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 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