From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: David Kastrup Newsgroups: gmane.lisp.guile.bugs Subject: bug#17485: [PATCH 2/3] Rewrite take-right, drop-right, drop-right! Date: Tue, 3 Jun 2014 20:56:17 +0200 Message-ID: <1401821778-19972-2-git-send-email-dak@gnu.org> References: <1401821778-19972-1-git-send-email-dak@gnu.org> NNTP-Posting-Host: plane.gmane.org X-Trace: ger.gmane.org 1401821845 29772 80.91.229.3 (3 Jun 2014 18:57:25 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 3 Jun 2014 18:57:25 +0000 (UTC) Cc: David Kastrup To: 17485@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Tue Jun 03 20:57:16 2014 Return-path: Envelope-to: guile-bugs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1Wrttc-0000Qt-94 for guile-bugs@m.gmane.org; Tue, 03 Jun 2014 20:57:16 +0200 Original-Received: from localhost ([::1]:55236 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Wrttb-0007U5-Le for guile-bugs@m.gmane.org; Tue, 03 Jun 2014 14:57:15 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:50238) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WrttX-0007Qr-DP for bug-guile@gnu.org; Tue, 03 Jun 2014 14:57:12 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1WrttQ-0008Qp-54 for bug-guile@gnu.org; Tue, 03 Jun 2014 14:57:11 -0400 Original-Received: from debbugs.gnu.org ([140.186.70.43]:43653) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WrttQ-0008Ql-19 for bug-guile@gnu.org; Tue, 03 Jun 2014 14:57:04 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.80) (envelope-from ) id 1WrttP-0007Cz-Rb for bug-guile@gnu.org; Tue, 03 Jun 2014 14:57:03 -0400 X-Loop: help-debbugs@gnu.org Resent-From: David Kastrup Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Tue, 03 Jun 2014 18:57:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 17485 X-GNU-PR-Package: guile X-GNU-PR-Keywords: Original-Received: via spool by 17485-submit@debbugs.gnu.org id=B17485.140182181227672 (code B ref 17485); Tue, 03 Jun 2014 18:57:03 +0000 Original-Received: (at 17485) by debbugs.gnu.org; 3 Jun 2014 18:56:52 +0000 Original-Received: from localhost ([127.0.0.1]:42528 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1WrttD-0007CE-4C for submit@debbugs.gnu.org; Tue, 03 Jun 2014 14:56:52 -0400 Original-Received: from fencepost.gnu.org ([208.118.235.10]:54719 ident=Debian-exim) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1WrttA-0007C0-6K for 17485@debbugs.gnu.org; Tue, 03 Jun 2014 14:56:49 -0400 Original-Received: from localhost ([127.0.0.1]:33783 helo=lola) by fencepost.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Wrtst-0001m6-AD; Tue, 03 Jun 2014 14:56:31 -0400 Original-Received: by lola (Postfix, from userid 1000) id AC0D1E0891; Tue, 3 Jun 2014 20:56:30 +0200 (CEST) X-Mailer: git-send-email 1.9.1 In-Reply-To: <1401821778-19972-1-git-send-email-dak@gnu.org> X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.15 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 140.186.70.43 X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.bugs:7483 Archived-At: * module/srfi/srfi-1.scm (take-right, drop-right, drop-right!): The definitions tended to be overly complicate and/or rely on pushing material on the VM stack, detrimental to scalability for Guile 2.0 and also worse for performance. The changed definitions lead to different, more accurate exceptions being raised. They rely on length+ returning the length of dotted lists, behavior that is not specified by the SRFI-1 definition but available in GUILE. Signed-off-by: David Kastrup --- module/srfi/srfi-1.scm | 44 ++++++++++++++++++++------------------------ test-suite/tests/srfi-1.test | 24 ++++++++++++------------ 2 files changed, 32 insertions(+), 36 deletions(-) diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index bc72048..73d164a 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -363,21 +363,24 @@ end-of-list checking in contexts where dotted lists are allowed." (define take list-head) (define drop list-tail) -;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, -;;; off by K, then chasing down the list until the lead pointer falls off -;;; the end. Note that they diverge for circular lists. +;;; TAKE-RIGHT and DROP-RIGHT make use of this implementation's length+ +;;; being defined for dotted lists. They error out for circular lists. (define (take-right lis k) - (let lp ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - lag))) + (let ((len (length+ lis))) + (if len + (if (<= 0 k len) + (drop lis (- len k)) + (out-of-range 'take-right k)) + (wrong-type-arg 'take-right lis)))) (define (drop-right lis k) - (let recur ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (cons (car lag) (recur (cdr lag) (cdr lead))) - '()))) + (let ((len (length+ lis))) + (if len + (if (<= 0 k len) + (take lis (- len k)) + (out-of-range 'drop-right k)) + (wrong-type-arg 'drop-right lis)))) (define (take! lst i) "Linear-update variant of `take'." @@ -389,19 +392,12 @@ end-of-list checking in contexts where dotted lists are allowed." (define (drop-right! lst i) "Linear-update variant of `drop-right'." - (let ((tail (drop lst i))) - (if (null? tail) - '() - (let loop ((prev lst) - (tail (cdr tail))) - (if (null? tail) - (if (pair? prev) - (begin - (set-cdr! prev '()) - lst) - lst) - (loop (cdr prev) - (cdr tail))))))) + (let ((len (length+ lst))) + (if len + (if (<= 0 i len) + (take! lst (- len i)) + (out-of-range 'drop-right! i)) + (wrong-type-arg 'drop-right! lst)))) (define (split-at lst i) "Return two values, a list of the elements before index I in LST, and diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index 9364ea2..032bfa4 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -877,14 +877,14 @@ (pass-if-exception "() -1" exception:out-of-range (drop-right '() -1)) (pass-if (equal? '() (drop-right '() 0))) - (pass-if-exception "() 1" exception:wrong-type-arg + (pass-if-exception "() 1" exception:out-of-range (drop-right '() 1)) (pass-if-exception "(1) -1" exception:out-of-range (drop-right '(1) -1)) (pass-if (equal? '(1) (drop-right '(1) 0))) (pass-if (equal? '() (drop-right '(1) 1))) - (pass-if-exception "(1) 2" exception:wrong-type-arg + (pass-if-exception "(1) 2" exception:out-of-range (drop-right '(1) 2)) (pass-if-exception "(4 5) -1" exception:out-of-range @@ -892,7 +892,7 @@ (pass-if (equal? '(4 5) (drop-right '(4 5) 0))) (pass-if (equal? '(4) (drop-right '(4 5) 1))) (pass-if (equal? '() (drop-right '(4 5) 2))) - (pass-if-exception "(4 5) 3" exception:wrong-type-arg + (pass-if-exception "(4 5) 3" exception:out-of-range (drop-right '(4 5) 3)) (pass-if-exception "(4 5 6) -1" exception:out-of-range @@ -901,7 +901,7 @@ (pass-if (equal? '(4 5) (drop-right '(4 5 6) 1))) (pass-if (equal? '(4) (drop-right '(4 5 6) 2))) (pass-if (equal? '() (drop-right '(4 5 6) 3))) - (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg + (pass-if-exception "(4 5 6) 4" exception:out-of-range (drop-right '(4 5 6) 4)) (pass-if "(a b . c) 0" @@ -918,14 +918,14 @@ (pass-if-exception "() -1" exception:out-of-range (drop-right! '() -1)) (pass-if (equal? '() (drop-right! '() 0))) - (pass-if-exception "() 1" exception:wrong-type-arg + (pass-if-exception "() 1" exception:out-of-range (drop-right! '() 1)) (pass-if-exception "(1) -1" exception:out-of-range (drop-right! (list 1) -1)) (pass-if (equal? '(1) (drop-right! (list 1) 0))) (pass-if (equal? '() (drop-right! (list 1) 1))) - (pass-if-exception "(1) 2" exception:wrong-type-arg + (pass-if-exception "(1) 2" exception:out-of-range (drop-right! (list 1) 2)) (pass-if-exception "(4 5) -1" exception:out-of-range @@ -933,7 +933,7 @@ (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0))) (pass-if (equal? '(4) (drop-right! (list 4 5) 1))) (pass-if (equal? '() (drop-right! (list 4 5) 2))) - (pass-if-exception "(4 5) 3" exception:wrong-type-arg + (pass-if-exception "(4 5) 3" exception:out-of-range (drop-right! (list 4 5) 3)) (pass-if-exception "(4 5 6) -1" exception:out-of-range @@ -942,7 +942,7 @@ (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1))) (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2))) (pass-if (equal? '() (drop-right! (list 4 5 6) 3))) - (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg + (pass-if-exception "(4 5 6) 4" exception:out-of-range (drop-right! (list 4 5 6) 4))) ;; @@ -2603,14 +2603,14 @@ (pass-if-exception "() -1" exception:out-of-range (take-right '() -1)) (pass-if (equal? '() (take-right '() 0))) - (pass-if-exception "() 1" exception:wrong-type-arg + (pass-if-exception "() 1" exception:out-of-range (take-right '() 1)) (pass-if-exception "(1) -1" exception:out-of-range (take-right '(1) -1)) (pass-if (equal? '() (take-right '(1) 0))) (pass-if (equal? '(1) (take-right '(1) 1))) - (pass-if-exception "(1) 2" exception:wrong-type-arg + (pass-if-exception "(1) 2" exception:out-of-range (take-right '(1) 2)) (pass-if-exception "(4 5) -1" exception:out-of-range @@ -2618,7 +2618,7 @@ (pass-if (equal? '() (take-right '(4 5) 0))) (pass-if (equal? '(5) (take-right '(4 5) 1))) (pass-if (equal? '(4 5) (take-right '(4 5) 2))) - (pass-if-exception "(4 5) 3" exception:wrong-type-arg + (pass-if-exception "(4 5) 3" exception:out-of-range (take-right '(4 5) 3)) (pass-if-exception "(4 5 6) -1" exception:out-of-range @@ -2627,7 +2627,7 @@ (pass-if (equal? '(6) (take-right '(4 5 6) 1))) (pass-if (equal? '(5 6) (take-right '(4 5 6) 2))) (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3))) - (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg + (pass-if-exception "(4 5 6) 4" exception:out-of-range (take-right '(4 5 6) 4)) (pass-if "(a b . c) 0" -- 1.9.1