mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

fix take-right and drop-right for improper lists

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-08-12 23:26:15 +02:00
parent 335c8a89a2
commit e7a81c7acd
4 changed files with 29 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

39
libguile/srfi-1.c
View file

@ -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)

2
libguile/srfi-1.h
View file

@ -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);

16
module/srfi/srfi-1.scm
View file

@ -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)

16
test-suite/tests/srfi-1.test
View file

@ -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