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: Re: [PATCH v4] Bound index checks in cl-seq functions Date: Mon, 06 Feb 2017 16:00:58 +0900 Message-ID: <87inon7qhh.fsf_-_@calancha-pc> References: <87efzdrjsj.fsf@calancha-pc> <87lgtlru13.fsf_-_@calancha-pc> <3026a9d6-fd50-ff2d-d702-d895402430c4@gmail.com> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-Trace: blaine.gmane.org 1486364527 12126 195.159.176.226 (6 Feb 2017 07:02:07 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Mon, 6 Feb 2017 07:02:07 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.0.50 (gnu/linux) Cc: Philipp Stephani , Noam Postavsky , Emacs developers , Tino Calancha To: =?utf-8?Q?Cl=C3=A9ment?= Pit-Claudel Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Mon Feb 06 08:02:02 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 1cadJJ-0002jn-Th for ged-emacs-devel@m.gmane.org; Mon, 06 Feb 2017 08:02:02 +0100 Original-Received: from localhost ([::1]:45826 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cadJM-0005LX-9b for ged-emacs-devel@m.gmane.org; Mon, 06 Feb 2017 02:02:04 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:43656) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cadIU-0005LI-4H for emacs-devel@gnu.org; Mon, 06 Feb 2017 02:01:16 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cadIQ-0002bQ-6j for emacs-devel@gnu.org; Mon, 06 Feb 2017 02:01:10 -0500 Original-Received: from mail-pg0-x241.google.com ([2607:f8b0:400e:c05::241]:33265) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cadIP-0002aS-Qq for emacs-devel@gnu.org; Mon, 06 Feb 2017 02:01:06 -0500 Original-Received: by mail-pg0-x241.google.com with SMTP id 194so8319905pgd.0 for ; Sun, 05 Feb 2017 23:01:05 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version:content-transfer-encoding; bh=Y5TDAcbsb3QR5DbZ+BFl58mBib2dp8f8Z4SY0jEBRrU=; b=X/i5n0ADHZeY1UcXvKFTtTRhYnY0D4AD6aVNaqtvFSspPSvquhYeklrFXyrICpCycO I5Nj6i9AlRKQePN+a0P5/V0P6nxJ5dNI/6lu63qPuPgQPlg8O0XSjjiZ4w43l1efl0kH uwtyDmB6PT1mRBiJ+WsjP4fusZEe0772CTJXx4isvoO6F3qdVGfl+F2JSnln+mnVo59z 8BZ0ajOBM6MuSBk7unlFT+j6dwGTfyv2vxpYf0CH80fL/z3Qosvc1fv8ZNIGhqOzegJT LMhh+jzR71MAZFs0MIvN6Ivs4fTkE5k8oLv+7ui89JYhreVeAxziqlA79MCGEWdqf98E d+Ww== 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:references:date:in-reply-to :message-id:user-agent:mime-version:content-transfer-encoding; bh=Y5TDAcbsb3QR5DbZ+BFl58mBib2dp8f8Z4SY0jEBRrU=; b=UFeMfLZwjDnZ+FcW2a1lfMavmz8OvSaZoFyhhyp/Il4xg73s9lhL3P7J1DUe43sR58 3/GzeAK7dQjDLMUkrJCfZ2a5b6cpuKxbpq/Ig9kiIFva1+CQU5aWsKtfnxYfPFs2Jf7M pQOlddIebXugKyE0nKm8ZpZvCiwZcjUqeScQ+qFgQ/jq+ecE9HPorNapjgozHCbtJGP0 VWAz3TyDOxKZ1HVMZa0O0Rs6F6djH4dIrVo6xGqjZWLnVCeBo5G64BUl38bLWr2qM+Fj NygpOXcbJsGYSMiR3AcjNVjtIvAZ3QF7qFGXgFzR+AcTz5/NWdaEpdwKKpaJPgEpf8Js m2eA== X-Gm-Message-State: AIkVDXImDl15j29zC6g+/Re8k9OU2zCqlTPYknEZ6Dc8FPytY8YEFMhTv7OXTtF6tm7Irg== X-Received: by 10.98.130.206 with SMTP id w197mr11519540pfd.5.1486364464417; Sun, 05 Feb 2017 23:01:04 -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 b10sm86588535pga.21.2017.02.05.23.01.01 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Sun, 05 Feb 2017 23:01:03 -0800 (PST) In-Reply-To: <3026a9d6-fd50-ff2d-d702-d895402430c4@gmail.com> (=?utf-8?Q?=22Cl=C3=A9ment?= Pit-Claudel"'s message of "Sun, 5 Feb 2017 11:11:22 -0500") X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2607:f8b0:400e:c05::241 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:212020 Archived-At: Cl=C3=A9ment Pit-Claudel writes: > On 2017-02-05 02:11, Tino Calancha wrote: >> II) `cl--check-bound-indices' returns on success the sequence[s] >> length[s], so that callers don't need to recompute them. > > This sounds like a good idea, performance wise. But maybe it would be > even better to disable these checks when (cl-declaim (optimize (safety > 0))) is set? Yes, that sounds right. The new patch disables those checks in that case (safety =3D 0). I got ~0.92 s without checks and ~ 1.10 with checks when i ran the following toy: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; start ;; -*- lexical-binding: t; -*- (require 'cl-lib) (cl-declaim (optimize (safety 0))) ; (test) ~ 0.92 ;(cl-declaim (optimize (safety 1))) ; (test) ~ 1.10 =20=20=20=20=20=20=20 (defun test () (let ((lst (nreverse (cons 'a (number-sequence 1 1000000))))) (benchmark-run 10 (cl-position 'a lst)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; end Following is the updated patch: :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::= :::: >From a57cc0105e315382715edba1baa9b814b947675d Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Mon, 6 Feb 2017 15:20: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. Suppress these checks if 'cl--optimize-safety' 0. * 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 | 379 +++++++++++++++++++++----------= ---- test/lisp/emacs-lisp/cl-seq-tests.el | 95 +++++++++ 4 files changed, 335 insertions(+), 147 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 <=3D @var{start} <=3D @var{end} <=3D (length @var{seq})}. +@code{0 <=3D @var{start} <=3D @var{end} <=3D (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 4d8ae091a7..19dd5d9995 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -706,6 +706,10 @@ processes on exit. * Incompatible Lisp Changes in Emacs 26.1 =20 +++ +** 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. =20 diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 67ff1a00bd..4ea9ebb063 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -42,6 +42,9 @@ ;;; Code: =20 (require 'cl-lib) +(eval-when-compile (require 'subr-x)) + +(defvar cl--optimize-safety) =20 ;; Keyword parsing. ;; This is special-cased here so that we can compile @@ -59,7 +62,14 @@ 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 (not (zerop cl--optimize-safety)) + (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 +122,49 @@ cl-test (defvar cl-if) (defvar cl-if-not) (defvar cl-key) =20 +;; 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 +181,7 @@ cl-reduce =20 \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) () + (or (zerop cl--optimize-safety) (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 +203,21 @@ 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) (>=3D (cl-decf n) 0))) - (setcar p cl-item) - (setq p (cdr p)))) - (or cl-end (setq cl-end (length cl-seq))) - (if (and (=3D cl-start 0) (=3D 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 (if (zerop cl--optimize-safety) + (or cl-end (length cl-seq)) + (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) (>=3D (cl-decf n) 0))) + (setcar p cl-item) + (setq p (cdr p)))) + (or cl-end (setq cl-end len)) + (if (and (=3D cl-start 0) (=3D 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)) =20 ;;;###autoload @@ -170,44 +227,48 @@ 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) (<=3D cl-start2 cl-start1)) - (or (=3D 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 (>=3D (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) (>=3D (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 (and (not (zerop cl--optimize-safety)) + (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys))) + (len1 (if lens (car lens) (or cl-end1 (length cl-seq1)))) + (len2 (if lens (cdr lens) (or cl-end2 (length cl-seq2))))) + (if (and (eq cl-seq1 cl-seq2) (<=3D cl-start2 cl-start1)) + (or (=3D 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 (>=3D (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) (>=3D (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)) =20 ;;;###autoload @@ -219,7 +280,9 @@ 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 (if (zerop cl--optimize-safety) + (length cl-seq) + (cl--check-bound-indices cl-seq nil cl-keys)))) (if (<=3D (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 +346,9 @@ 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 (if (zerop cl--optimize-safety) + (length cl-seq) + (cl--check-bound-indices cl-seq nil cl-keys)))) (if (<=3D (or cl-count (setq cl-count len)) 0) cl-seq (if (listp cl-seq) @@ -356,39 +421,42 @@ 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) (=3D 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 (if (zerop cl--optimize-safety) + (or cl-end (length cl-seq)) + (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-e= nd))) + (if cl-copy (setq cl-seq (copy-sequence cl-seq) + cl-p (nthcdr cl-start cl-seq) cl-cop= y 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) (=3D 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))))) =20 @@ -400,21 +468,24 @@ 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) - (<=3D (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 (if (zerop cl--optimize-safety) + (length cl-seq) + (cl--check-bound-indices cl-seq nil cl-keys)))) + (if (or (eq cl-old cl-new) + (<=3D (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))))))) =20 ;;;###autoload (defun cl-substitute-if (cl-new cl-pred cl-list &rest cl-keys) @@ -442,7 +513,9 @@ 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 (if (zerop cl--optimize-safety) + (length cl-seq) + (cl--check-bound-indices cl-seq nil cl-keys)))) (or (eq cl-old cl-new) (<=3D (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))) @@ -517,8 +590,11 @@ cl-position \nKeywords supported: :test :test-not :key :start :end :from-end \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))) + (:start 0) :end :from-end) () + (let ((end (if (not (zerop cl--optimize-safety)) + (cl--check-bound-indices cl-seq nil cl-keys) + cl-end))) + (cl--position cl-item cl-seq cl-start end cl-from-end)))) =20 (defun cl--position (cl-item cl-seq cl-start &optional cl-end cl-from-end) (if (listp cl-seq) @@ -562,8 +638,11 @@ 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 (if (zerop cl--optimize-safety) + (or cl-end (length cl-seq)) + (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 +672,32 @@ cl-mismatch \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :f= rom-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 (and (not (zerop cl--optimize-safety)) + (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys))) + (len1 (if lens (car lens) (or cl-end1 (length cl-seq1)))) + (len2 (if lens (cdr lens) (or cl-end2 (length cl-seq2))))) + (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)))))) =20 ;;;###autoload (defun cl-search (cl-seq1 cl-seq2 &rest cl-keys) @@ -624,24 +707,28 @@ cl-search \nKeywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :f= rom-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 (>=3D 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-e= nd)) - (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 (and (not (zerop cl--optimize-safety)) + (cl--check-bound-indices cl-seq1 cl-seq2 cl-keys))) + (len1 (if lens (car lens) (or cl-end1 (length cl-seq1)))) + (len2 (if lens (cdr lens) (or cl-end2 (length cl-seq2))))) + (or cl-end1 (setq cl-end1 len1)) + (or cl-end2 (setq cl-end2 len2)) + (if (>=3D 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-p= os)))) + (and (< cl-start2 cl-end2) cl-pos)))))) =20 ;;;###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))))) =20 +(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-]+\\) :e= nd\\([1-2]?\\)" x) + x) + ((string=3D 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)))))))) + =20 (provide 'cl-seq-tests) ;;; cl-seq-tests.el ends here --=20 2.11.0 >From be0427570b987e942c934ab8ee841dc326a1a0be Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Mon, 6 Feb 2017 15:21:03 +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) --=20 2.11.0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;= ;;;; In GNU Emacs 26.0.50.1 (x86_64-pc-linux-gnu, GTK+ Version 3.22.7) of 2017-02-06 Repository revision: d45dbccc5d2360818e70bbb0bc816c62c8cf6cbe