mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

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

Browse source 
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.
This commit is contained in:
Mark H Weaver 2014-04-18 15:04:12 -04:00
parent 12c6a47773
commit a5186f506f
2 changed files with 33 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

32
libguile/srfi-1.c
View file

@ -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

6
test-suite/tests/srfi-1.test
View file

@ -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))))