summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/srfi-1.c39
-rw-r--r--libguile/srfi-1.h2
-rw-r--r--module/srfi/srfi-1.scm16
-rw-r--r--test-suite/tests/srfi-1.test16
4 files changed, 29 insertions, 44 deletions
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 37441f788..ed6d3d9d1 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 13ab067bd..47607bc55 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 c60f6257f..0809625fc 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 eaad8c961..d40f8e1c2 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