SRFI-1 'length+' raises an error unless passed a proper or circular list.

Fixes <http://bugs.gnu.org/17296>.

* libguile/srfi-1.c (scm_srfi1_length_plus): Rewrite to raise an error
  unless passed a proper or circular list, based on code from
  'scm_ilength'.

* test-suite/tests/srfi-1.test (length+): Add tests.

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 54c7e2a..fcbf806 100644 (file)
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -1,7 +1,7 @@
 /* srfi-1.c --- SRFI-1 procedures for Guile
  *
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006,
- *   2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011,
+ *   2014 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -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);
+  size_t i = 0;
+  SCM tortoise = lst;
+  SCM hare = lst;
+
+  do
+    {
+      if (SCM_NULL_OR_NIL_P (hare))
+        return scm_from_size_t (i);
+      if (!scm_is_pair (hare))
+        scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, "proper or circular list");
+      hare = SCM_CDR (hare);
+      i++;
+      if (SCM_NULL_OR_NIL_P (hare))
+        return scm_from_size_t (i);
+      if (!scm_is_pair (hare))
+        scm_wrong_type_arg_msg (FUNC_NAME, 1, lst, "proper or circular list");
+      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/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index d40f8e1..bce0e86 100644 (file)
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1,6 +1,6 @@
 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
 ;;;;
-;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright 2003-2006, 2008-2011, 2014 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1329,6 +1329,10 @@
     (length+))
   (pass-if-exception "too many args" exception:wrong-num-args
     (length+ 123 456))
+  (pass-if-exception "not a pair" exception:wrong-type-arg
+    (length+ 'x))
+  (pass-if-exception "improper list" exception:wrong-type-arg
+    (length+ '(x y . z)))
   (pass-if (= 0 (length+ '())))
   (pass-if (= 1 (length+ '(x))))
   (pass-if (= 2 (length+ '(x y))))