diff options
-rw-r--r-- | libguile/srfi-1.c | 39 | ||||
-rw-r--r-- | libguile/srfi-1.h | 2 | ||||
-rw-r--r-- | module/srfi/srfi-1.scm | 16 | ||||
-rw-r--r-- | 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 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 |