bug#17485: [PATCH 2/3] Rewrite take-right, drop-right, drop-right!

[David Kastrup]

* 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 <address@hidden>
---
 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