From 7b24df6656a86a06fc7c7430d8e56a762d88da10 Mon Sep 17 00:00:00 2001 From: =?utf-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 31 Aug 2008 23:48:17 +0200 Subject: [PATCH] Report an error for circular lists in `list-copy'. * libguile/list.c (scm_list_copy): Use the "tortoise and the hare" algorithm to detect circular lists and report an error. * test-suite/tests/list.test (list-copy): New tests. --- libguile/list.c | 18 ++++++++++++++++-- test-suite/tests/list.test | 16 +++++++++++++++- 2 files changed, 31 insertions(+), 3 deletions(-) diff --git a/libguile/list.c b/libguile/list.c index 8b0a2e4..256c1fd 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -548,14 +548,14 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, { SCM newlst; SCM * fill_here; - SCM from_here; + SCM from_here, hare; SCM_ASSERT (scm_is_pair (lst) || SCM_NULL_OR_NIL_P (lst), lst, 1, FUNC_NAME); newlst = SCM_EOL; fill_here = &newlst; - from_here = lst; + from_here = hare = lst; while (scm_is_pair (from_here)) { @@ -564,6 +564,20 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, *fill_here = c; fill_here = SCM_CDRLOC (c); from_here = SCM_CDR (from_here); + + /* Use the "tortoise and the hare" algorithm to detect circular + lists. */ + if (scm_is_pair (hare)) + { + hare = SCM_CDR (hare); + if (scm_is_pair (hare)) + { + hare = SCM_CDR (hare); + if (scm_is_pair (hare)) + SCM_ASSERT (!scm_is_eq (hare, from_here), + lst, 1, FUNC_NAME); + } + } } return newlst; } diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index 7dc0ef0..514fe2a 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -1,5 +1,5 @@ ;;;; list.test --- tests guile's lists -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006, 2008 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 @@ -655,6 +655,20 @@ ;;; list-copy +(with-test-prefix "list-copy" + + (pass-if "empty list" + (null? (list-copy '()))) + + (pass-if "non-empty list" + (let ((lst (iota 123))) + (equal? (list-copy lst) lst))) + + (pass-if-exception "circular list" + exception:wrong-type-arg + (let ((lst (list 1))) + (set-cdr! lst lst) + (list-copy lst)))) ;;; memq -- 1.6.0