Subject: bug#17296: closed (Re: bug#17296: [PATCH] SRFI-1 'length+' raises an error unless passed a proper or circular list)

From: [email-masked] (GNU bug Tracking System)
Date: Mon, 02 Jun 2014 00:57:02 +0000

Your bug report

#17296: [PATCH] SRFI-1 'length+' raises an error unless passed a proper or circular list

which was filed against the guile package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
17296: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=17296
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: bug#17296: [PATCH] SRFI-1 'length+' raises an error unless passed a proper or circular list
From: Mark H Weaver <[email-masked]>
To: [email-masked]
Date: Sun, 01 Jun 2014 20:56:21 -0400
List-Id: <debbugs-submit.debbugs.gnu.org>

Mark H Weaver <[email-masked]> writes:

> According to the SRFI-1 spec, 'length+' must be passed a proper or
> circular list.  It should raise an error when passed a non-pair or an
> improper list, but instead it returns #f in such cases:
>
> scheme@(guile-user)> (use-modules (srfi srfi-1))
> scheme@(guile-user)> (length+ 5)
> $1 = #f
> scheme@(guile-user)> (length+ 'x)
> $2 = #f
> scheme@(guile-user)> (length+ '(x . y))
> $3 = #f
>
> One side effect of this is that SRFI-1 'map', which uses 'length+' to
> validate the arguments and find the shortest length, accepts improper
> lists and non-pairs as arguments as long as one of the arguments is a
> proper list:
>
> scheme@(guile-user)> (map + '(1 2) '(1 2 3 . 4))
> $4 = (2 4)
> scheme@(guile-user)> (map + '() 2)
> $5 = ()
> scheme@(guile-user)> (map + '(1) 2)
> ERROR: In procedure cdr:
> ERROR: In procedure cdr: Wrong type (expecting pair): 2
>
> The attached patch fixes these problems.

Pushed to stable-2.0, commit a5186f506f69ef8a8accd234ca434efd13f302c9.

I'm closing this bug.

      Mark

Subject: [PATCH] SRFI-1 'length+' raises an error unless passed a proper or circular list
From: Mark H Weaver <[email-masked]>
To: [email-masked]
Date: Fri, 18 Apr 2014 15:26:48 -0400
List-Id: <debbugs-submit.debbugs.gnu.org>

According to the SRFI-1 spec, 'length+' must be passed a proper or
circular list.  It should raise an error when passed a non-pair or an
improper list, but instead it returns #f in such cases:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> (use-modules (srfi srfi-1))
scheme@(guile-user)> (length+ 5)
$1 = #f
scheme@(guile-user)> (length+ 'x)
$2 = #f
scheme@(guile-user)> (length+ '(x . y))
$3 = #f
--8<---------------cut here---------------end--------------->8---

One side effect of this is that SRFI-1 'map', which uses 'length+' to
validate the arguments and find the shortest length, accepts improper
lists and non-pairs as arguments as long as one of the arguments is a
proper list:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> (map + '(1 2) '(1 2 3 . 4))
$4 = (2 4)
scheme@(guile-user)> (map + '() 2)
$5 = ()
scheme@(guile-user)> (map + '(1) 2)
ERROR: In procedure cdr:
ERROR: In procedure cdr: Wrong type (expecting pair): 2
--8<---------------cut here---------------end--------------->8---

The attached patch fixes these problems.

     Mark

>From 1daa266dd0a6381c58eba950dd935686dadee166 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
Date: Fri, 18 Apr 2014 15:04:12 -0400
Subject: [PATCH] SRFI-1 'length+' raises an error unless passed a proper or
 circular list.

* 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.
---
 libguile/srfi-1.c            | 30 +++++++++++++++++++++++++++---
 test-suite/tests/srfi-1.test |  7 ++++++-
 2 files changed, 33 insertions(+), 4 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 54c7e2a..a7ffeec 100644
--- 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.
+ *   2008, 2009, 2010, 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..9a2ed94 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1,6 +1,7 @@
 ;;;; 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, 2004, 2005, 2006, 2008, 2009, 2010, 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 +1330,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))))
-- 
1.8.4