[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-40-ge7a81c7

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=e7a81c7acdc0501b3fca6cdd51eb05d4fe39d317

The branch, stable-2.0 has been updated
       via  e7a81c7acdc0501b3fca6cdd51eb05d4fe39d317 (commit)
      from  335c8a89a2e1dfb362b7a52010da4a81ab9cffc9 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit e7a81c7acdc0501b3fca6cdd51eb05d4fe39d317
Author: Andy Wingo <address@hidden>
Date:   Fri Aug 12 23:26:15 2011 +0200

    fix take-right and drop-right for improper lists
    
    * libguile/srfi-1.h:
    * libguile/srfi-1.c (scm_srfi1_drop_right, scm_srfi1_take_right): Remove
      these internal functions, replacing with Scheme implementations.
    
    * module/srfi/srfi-1.scm (take-right, drop-right): Add these impls from
      the reference code.  They do the right thing for improper lists,
      according to the spec, but they diverge for circular lists.  Oh well.
    
    * test-suite/tests/srfi-1.test ("drop-right", "take-right"): Add more
      tests.

-----------------------------------------------------------------------

Summary of changes:
 libguile/srfi-1.c            |   39 ---------------------------------------
 libguile/srfi-1.h            |    2 --
 module/srfi/srfi-1.scm       |   16 ++++++++++++++++
 test-suite/tests/srfi-1.test |   16 +++++++++++++---
 4 files changed, 29 insertions(+), 44 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 37441f7..ed6d3d9 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -568,28 +568,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, 
"delete-duplicates!", 1, 1, 0,
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
-            (SCM lst, SCM n),
-           "Return a new list containing all except the last @var{n}\n"
-           "elements of @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_drop_right
-{
-  SCM tail = scm_list_tail (lst, n);
-  SCM ret = SCM_EOL;
-  SCM *rend = &ret;
-  while (scm_is_pair (tail))
-    {
-      *rend = scm_cons (SCM_CAR (lst), SCM_EOL);
-      rend = SCM_CDRLOC (*rend);
-      
-      lst = SCM_CDR (lst);
-      tail = SCM_CDR (tail);
-    }
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
-  return ret;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
             (SCM pred, SCM lst),
            "Return the first element of @var{lst} which satisfies the\n"
@@ -924,23 +902,6 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
-            (SCM lst, SCM n),
-           "Return a list containing the @var{n} last elements of\n"
-           "@var{lst}.")
-#define FUNC_NAME s_scm_srfi1_take_right
-{
-  SCM tail = scm_list_tail (lst, n);
-  while (scm_is_pair (tail))
-    {
-      lst = SCM_CDR (lst);
-      tail = SCM_CDR (tail);
-    }
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
-  return lst;
-}
-#undef FUNC_NAME
-
 
 void
 scm_register_srfi_1 (void)
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 13ab067..47607bc 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -33,7 +33,6 @@ SCM_INTERNAL SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_drop_right (SCM lst, SCM n);
 SCM_INTERNAL SCM scm_srfi1_find (SCM pred, SCM lst);
 SCM_INTERNAL SCM scm_srfi1_find_tail (SCM pred, SCM lst);
 SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
@@ -44,7 +43,6 @@ SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_remove_x (SCM pred, SCM list);
-SCM_INTERNAL SCM scm_srfi1_take_right (SCM lst, SCM n);
 
 SCM_INTERNAL void scm_register_srfi_1 (void);
 SCM_INTERNAL void scm_init_srfi_1 (void);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index c60f625..0809625 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -360,6 +360,22 @@ end-of-list checking in contexts where dotted lists are 
allowed."
 (define take list-head)
 (define drop list-tail)
 
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end.  Note that they diverge for circular lists.
+
+(define (take-right lis k)
+  (let lp ((lag lis)  (lead (drop lis k)))
+    (if (pair? lead)
+       (lp (cdr lag) (cdr lead))
+       lag)))
+
+(define (drop-right lis k)
+  (let recur ((lag lis) (lead (drop lis k)))
+    (if (pair? lead)
+       (cons (car lag) (recur (cdr lag) (cdr lead)))
+       '())))
+
 (define (take! lst i)
   "Linear-update variant of `take'."
   (if (= i 0)
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index eaad8c9..d40f8e1 100644
--- 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 Free Software 
Foundation, Inc.
+;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011 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
@@ -902,7 +902,12 @@
   (pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
   (pass-if (equal? '() (drop-right '(4 5 6) 3)))
   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
-    (drop-right '(4 5 6) 4)))
+    (drop-right '(4 5 6) 4))
+
+  (pass-if "(a b . c) 0"
+    (equal? (drop-right '(a b . c) 0) '(a b)))
+  (pass-if "(a b . c) 1"
+    (equal? (drop-right '(a b . c) 1) '(a))))
 
 ;;
 ;; drop-right!
@@ -2621,7 +2626,12 @@
   (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
   (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
   (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
-    (take-right '(4 5 6) 4)))
+    (take-right '(4 5 6) 4))
+
+  (pass-if "(a b . c) 0"
+    (equal? (take-right '(a b . c) 0) 'c))
+  (pass-if "(a b . c) 1"
+    (equal? (take-right '(a b . c) 1) '(b . c))))
 
 ;;
 ;; tenth


hooks/post-receive
-- 
GNU Guile