[PATCH] Avoid `SCM_VALIDATE_LIST ()'

[Ludovic Courtès]

Hello,

This is a followup to this discussion:

  http://thread.gmane.org/gmane.lisp.guile.devel/7194

The attached patch changes several list-related functions so that they
don't validate their input with `SCM_VALIDATE_LIST ()' since it's O(n).

A side-effect (besides performance improvements) is that all these
functions will now happily traverse circular lists, and will silently
deal with dotted lists.  This is acceptable behavior IMO.

Nevertheless, the second patch below implements the "tortoise and the
hare" in `list-copy' so that it detects circular list; it seems
worthwhile to check that here since `list-copy' would otherwise exhaust
memory.

(Note that SRFI-1's `list-copy' *does* accept improper lists, including
circular lists, although SRFI-1 does not explicitly mention that it
should handle improper list.)

Also, in some cases, the `wrong-type-arg' message is different (but the
exception key is the same).

OK to apply to both branches?

Thanks,
Ludo'.

>From 8df8aaafb2bed534db5e7a3a9337cd9c8f38523c Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Sun, 31 Aug 2008 23:04:10 +0200
Subject: [PATCH] Avoid using `SCM_VALIDATE_LIST ()' since it has O(n) 
complexity.

* libguile/list.c (scm_reverse_x, scm_list_copy, scm_memq, scm_memv,
  scm_member, scm_filter, scm_filter_x): Don't use
  `SCM_VALIDATE_LIST ()' since it's O(n).  Use `SCM_VALIDATE_CONS ()'
  when traversing the input lists.

* srfi/srfi-1.c (scm_srfi1_concatenate, scm_srfi1_concatenate_x):
  Don't use `SCM_VALIDATE_LIST ()' on LSTLST; instead, simply make
  sure it's either the empty list or a pair.
  (scm_srfi1_member, scm_srfi1_remove, scm_srfi1_remove_x): Don't use
  `SCM_VALIDATE_LIST ()' since it's O(n).  Use `SCM_VALIDATE_CONS ()'
  when traversing the input lists.
---
 NEWS            |    7 +++++++
 libguile/list.c |   40 +++++++++++++++++++++++++++-------------
 srfi/srfi-1.c   |   22 +++++++++++++++-------
 3 files changed, 49 insertions(+), 20 deletions(-)

diff --git a/NEWS b/NEWS
index c2bed17..cfcd43b 100644
--- a/NEWS
+++ b/NEWS
@@ -56,6 +56,13 @@ When you use GDS to evaluate Scheme code from Emacs, you can 
now use
 This makes these internal functions technically not callable from
 application code.
 
+** Remove argument type checking with `list?' in some list-related functions
+
+Several list-related functions (e.g., `memq', `list-copy', etc.) used
+R5RS `list?' to validate their arguments.  However, `list?' has linear
+complexity, so these functions have been changed to not resort to
+`list?'.
+
 ** `guile-config link' now prints `-L$libdir' before `-lguile'
 ** Fix memory corruption involving GOOPS' `class-redefinition'
 ** Fix build issue on Tru64 and ia64-hp-hpux11.23 (`SCM_UNPACK' macro)
diff --git a/libguile/list.c b/libguile/list.c
index a1a79a4..8b0a2e4 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004
+/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008
  * Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
@@ -367,15 +367,19 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
            "@code{reverse!}")
 #define FUNC_NAME s_scm_reverse_x
 {
-  SCM_VALIDATE_LIST (1, lst);
   if (SCM_UNBNDP (new_tail))
     new_tail = SCM_EOL;
   else
-    SCM_VALIDATE_LIST (2, new_tail);
+    SCM_ASSERT (scm_is_pair (new_tail) || SCM_NULL_OR_NIL_P (new_tail),
+               new_tail, 2, FUNC_NAME);
 
   while (!SCM_NULL_OR_NIL_P (lst))
     {
-      SCM old_tail = SCM_CDR (lst);
+      SCM old_tail;
+
+      SCM_VALIDATE_CONS (1, lst);
+
+      old_tail = SCM_CDR (lst);
       SCM_SETCDR (lst, new_tail);
       new_tail = lst;
       lst = old_tail;
@@ -546,7 +550,8 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
   SCM * fill_here;
   SCM from_here;
 
-  SCM_VALIDATE_LIST (1, lst);
+  SCM_ASSERT (scm_is_pair (lst) || SCM_NULL_OR_NIL_P (lst),
+             lst, 1, FUNC_NAME);
 
   newlst = SCM_EOL;
   fill_here = &newlst;
@@ -613,8 +618,13 @@ SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
            "returned.")
 #define FUNC_NAME s_scm_memq
 {
-  SCM_VALIDATE_LIST (2, lst);
-  return scm_c_memq (x, lst);
+  for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
+    {
+      SCM_VALIDATE_CONS (2, lst);
+      if (scm_is_eq (SCM_CAR (lst), x))
+       return lst;
+    }
+  return SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
@@ -629,9 +639,9 @@ SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
            "returned.")
 #define FUNC_NAME s_scm_memv
 {
-  SCM_VALIDATE_LIST (2, lst);
   for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
     {
+      SCM_VALIDATE_CONS (2, lst);
       if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
        return lst;
     }
@@ -650,9 +660,9 @@ SCM_DEFINE (scm_member, "member", 2, 0, 0,
            "empty list) is returned.")
 #define FUNC_NAME s_scm_member
 {
-  SCM_VALIDATE_LIST (2, lst);
   for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
     {
+      SCM_VALIDATE_CONS (2, lst);
       if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
        return lst;
     }
@@ -884,9 +894,11 @@ SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
   SCM walk;
   SCM *prev;
   SCM res = SCM_EOL;
+
   SCM_ASSERT (call, pred, 1, FUNC_NAME);
-  SCM_VALIDATE_LIST (2, list);
-  
+  SCM_ASSERT (scm_is_pair (list) || SCM_NULL_OR_NIL_P (list),
+             list, 2, FUNC_NAME);
+
   for (prev = &res, walk = list;
        scm_is_pair (walk);
        walk = SCM_CDR (walk))
@@ -910,9 +922,11 @@ SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
   scm_t_trampoline_1 call = scm_trampoline_1 (pred);
   SCM walk;
   SCM *prev;
+
   SCM_ASSERT (call, pred, 1, FUNC_NAME);
-  SCM_VALIDATE_LIST (2, list);
-  
+  SCM_ASSERT (scm_is_pair (list) || SCM_NULL_OR_NIL_P (list),
+             list, 2, FUNC_NAME);
+
   for (prev = &list, walk = list;
        scm_is_pair (walk);
        walk = SCM_CDR (walk))
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 35815b3..e330d43 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -279,7 +279,8 @@ SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
            "limit.")
 #define FUNC_NAME s_scm_srfi1_concatenate
 {
-  SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
+  SCM_ASSERT (scm_is_pair (lstlst) || SCM_NULL_OR_NIL_P (lstlst),
+             lstlst, 1, FUNC_NAME);
   return scm_append (lstlst);
 }
 #undef FUNC_NAME
@@ -297,7 +298,8 @@ SCM_DEFINE (scm_srfi1_concatenate_x, "concatenate!", 1, 0, 
0,
            "limit.")
 #define FUNC_NAME s_scm_srfi1_concatenate
 {
-  SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
+  SCM_ASSERT (scm_is_pair (lstlst) || SCM_NULL_OR_NIL_P (lstlst),
+             lstlst, 1, FUNC_NAME);
   return scm_append_x (lstlst);
 }
 #undef FUNC_NAME
@@ -1582,7 +1584,7 @@ SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
 #define FUNC_NAME s_scm_srfi1_member
 {
   scm_t_trampoline_2 equal_p;
-  SCM_VALIDATE_LIST (2, lst);
+
   if (SCM_UNBNDP (pred))
     equal_p = equal_trampoline;
   else
@@ -1592,6 +1594,7 @@ SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
     }
   for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
     {
+      SCM_VALIDATE_CONS (2, lst);
       if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
        return lst;
     }
@@ -1898,13 +1901,16 @@ SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
   SCM walk;
   SCM *prev;
   SCM res = SCM_EOL;
+
   SCM_ASSERT (call, pred, 1, FUNC_NAME);
-  SCM_VALIDATE_LIST (2, list);
-  
+  SCM_ASSERT (scm_is_pair (list) || SCM_NULL_OR_NIL_P (list),
+             list, 2, FUNC_NAME);
+
   for (prev = &res, walk = list;
        scm_is_pair (walk);
        walk = SCM_CDR (walk))
     {
+      SCM_VALIDATE_CONS (2, walk);
       if (scm_is_false (call (pred, SCM_CAR (walk))))
        {
          *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
@@ -1930,9 +1936,11 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
   scm_t_trampoline_1 call = scm_trampoline_1 (pred);
   SCM walk;
   SCM *prev;
+
   SCM_ASSERT (call, pred, 1, FUNC_NAME);
-  SCM_VALIDATE_LIST (2, list);
-  
+  SCM_ASSERT (scm_is_pair (list) || SCM_NULL_OR_NIL_P (list),
+             list, 2, FUNC_NAME);
+
   for (prev = &list, walk = list;
        scm_is_pair (walk);
        walk = SCM_CDR (walk))
-- 
1.6.0

>From 7b24df6656a86a06fc7c7430d8e56a762d88da10 Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
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