bug#17485: [PATCH 1/3] Let length+ return the length of dotted lists rather than #f

[David Kastrup]

* libguile/srfi-1.c (scm_srfi1_length_plus): Previously, length+
  returned #f for dotted lists.  This leaves the user with no efficient
  means for determining the length of dotted lists.  While the Scheme
  standard does not prescribe a behavior here, the reference
  implementation at
  <URL:http://srfi.schemers.org/srfi-1/srfi-1-reference.scm> indeed
  returns the spine length (number of successive pairs in the cdr-chain)
  of dotted lists rather than #f, providing a good endorsement of this
  behavior.

  As one consequence, the multi-list implementations for map, fold, and
  for-each will happen to accept dotted lists as the shortest list.
  Previously, this caused an error late during processing.

Signed-off-by: David Kastrup <address@hidden>
---
 libguile/srfi-1.c            | 28 ++++++++++++++++++++++++++--
 module/srfi/srfi-1.scm       | 10 +++++-----
 test-suite/tests/srfi-1.test | 28 +++++++++++++++-------------
 3 files changed, 46 insertions(+), 20 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index aaa3efe..0db6388 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -614,8 +614,32 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
            "circular.")
 #define FUNC_NAME s_scm_srfi1_length_plus
 {
-  long len = scm_ilength (lst);
-  return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F);
+  /* This uses the "tortoise and hare" algorithm to detect "infinitely
+     long" lists (i.e. lists with cycles in their cdrs), and returns #f
+     if it does find one.
+
+     Dotted lists are treated just like regular lists, returning the
+     length of the spine.  This is in conformance with the reference
+     implementation though not explicitly defined in the standard. */
+  long i = 0;
+  SCM tortoise = lst;
+  SCM hare = lst;
+
+  do {
+    if (!scm_is_pair (hare)) return scm_from_long (i);
+    hare = SCM_CDR(hare);
+    i++;
+    if (!scm_is_pair (hare)) return scm_from_long (i);
+    hare = SCM_CDR(hare);
+    i++;
+    /* For every two steps the hare takes, the tortoise takes one.  */
+    tortoise = SCM_CDR(tortoise);
+  }
+  while (!scm_is_eq (hare, tortoise));
+
+  /* If the tortoise ever catches the hare, then the list must contain
+     a cycle.  */
+  return SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 0806e73..bc72048 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -474,7 +474,7 @@ that result.  See the manual for details."
                      (or len1 len2))))
        (unless len
          (scm-error 'wrong-type-arg "fold"
-                    "Args do not contain a proper (finite) list: ~S"
+                    "Args do not contain a finite list: ~S"
                     (list (list list1 list2)) #f))
        (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len))
          (if (zero? len)
@@ -601,7 +601,7 @@ has just one element then that's the return value."
                      (or len1 len2))))
        (unless len
          (scm-error 'wrong-type-arg "map"
-                    "Args do not contain a proper (finite) list: ~S"
+                    "Args do not contain a finite list: ~S"
                     (list (list l1 l2)) #f))
        (let map2 ((l1 l1) (l2 l2) (len len))
          (if (zero? len)
@@ -620,7 +620,7 @@ has just one element then that's the return value."
                       rest)))
        (if (not len)
            (scm-error 'wrong-type-arg "map"
-                      "Args do not contain a proper (finite) list: ~S"
+                      "Args do not contain a finite list: ~S"
                       (list (cons l1 rest)) #f))
        (let mapn ((l1 l1) (rest rest) (len len))
          (if (zero? len)
@@ -649,7 +649,7 @@ has just one element then that's the return value."
                      (or len1 len2))))
        (unless len
          (scm-error 'wrong-type-arg "for-each"
-                    "Args do not contain a proper (finite) list: ~S"
+                    "Args do not contain a finite list: ~S"
                     (list (list l1 l2)) #f))
        (let for-each2 ((l1 l1) (l2 l2) (len len))
          (unless (zero? len)
@@ -667,7 +667,7 @@ has just one element then that's the return value."
                       rest)))
        (if (not len)
            (scm-error 'wrong-type-arg "for-each"
-                      "Args do not contain a proper (finite) list: ~S"
+                      "Args do not contain a finite list: ~S"
                       (list (cons l1 rest)) #f))
        (let for-eachn ((l1 l1) (rest rest) (len len))
          (if (> len 0)
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index d40f8e1..9364ea2 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1187,19 +1187,21 @@
     (pass-if-exception "proc arg count 4" exception:wrong-num-args
       (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
 
-    (pass-if-exception "improper first 1" exception:wrong-type-arg
-      (fold + 1 1 '(1 2 3)))
-    (pass-if-exception "improper first 2" exception:wrong-type-arg
-      (fold + 1 '(1 . 2) '(1 2 3)))
-    (pass-if-exception "improper first 3" exception:wrong-type-arg
-      (fold + 1 '(1 2 . 3) '(1 2 3)))
-
-    (pass-if-exception "improper second 1" exception:wrong-type-arg
-      (fold + 1 '(1 2 3) 1))
-    (pass-if-exception "improper second 2" exception:wrong-type-arg
-      (fold + 1 '(1 2 3) '(1 . 2)))
-    (pass-if-exception "improper second 3" exception:wrong-type-arg
-      (fold + 1 '(1 2 3) '(1 2 . 3)))
+    ;; For multiple list arguments, dotted lists are permitted by this
+    ;; implementation and a non-list is a zero-length dotted list
+    (pass-if "improper first 1"
+      (= 1 (fold + 1 1 '(1 2 3))))
+    (pass-if "improper first 2"
+      (= 3 (fold + 1 '(1 . 2) '(1 2 3))))
+    (pass-if "improper first 3"
+      (= 7 (fold + 1 '(1 2 . 3) '(1 2 3))))
+
+    (pass-if "improper second 1"
+      (= 1 (fold + 1 '(1 2 3) 1)))
+    (pass-if "improper second 2"
+      (= 3 (fold + 1 '(1 2 3) '(1 . 2))))
+    (pass-if "improper second 3"
+      (= 7 (fold + 1 '(1 2 3) '(1 2 . 3))))
 
     (pass-if (= 6 (fold + 1 '(2) '(3))))
     (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))
-- 
1.9.1