mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

SRFI-1: Rewrite fifth', sixth', etc. in Scheme.

Browse source 
This partially reverts commit 03731332d5
(Tue May 3 2005).

* module/srfi/srfi-1.scm (fifth, sixth, seventh, eighth, ninth, tenth):
  New procedures.

* srfi/srfi-1.c (scm_srfi1_fifth, scm_srfi1_sixth, scm_srfi1_seventh,
  scm_srfi1_eighth, scm_srfi1_ninth, scm_srfi1_tenth): Rewrite as
  proxies to the corresponding Scheme procedure.

* test-suite/tests/srfi-1.test ("eighth")["() -1"]: Change exception
  type to `exception:wrong-type-arg'.
  ("fifth")["() -1"]: Likewise.
  ("ninth")["() -1"]: Likewise.
  ("seventh")["() -1"]: Likewise.
  ("sixth")["() -1"]: Likewise.
  ("tenth")["() -1"]: Likewise.
This commit is contained in:
Ludovic Courtès 2010-08-27 12:51:47 +02:00
parent ea975f72cf
commit d7418e60a5
3 changed files with 36 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -336,6 +336,12 @@ end-of-list checking in contexts where dotted lists are allowed."
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (fifth x) (car (cddddr x)))
(define (sixth x) (cadr (cddddr x)))
(define (seventh x) (caddr (cddddr x)))
(define (eighth x) (cadddr (cddddr x)))
(define (ninth x) (car (cddddr (cddddr x))))
(define (tenth x) (cadr (cddddr (cddddr x))))
(define (car+cdr x)
"Return two values, the `car' and the `cdr' of PAIR."

64
srfi/srfi-1.c
View file

@ -783,24 +783,19 @@ SCM_DEFINE (scm_srfi1_drop_while, "drop-while", 2, 0, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_eighth, "eighth", 1, 0, 0,
(SCM lst),
"Return the eighth element of @var{lst}.")
#define FUNC_NAME s_scm_srfi1_eighth
SCM
scm_srfi1_eighth (SCM lst)
{
return scm_list_ref (lst, SCM_I_MAKINUM (7));
CACHE_VAR (eighth, "eighth");
return scm_call_1 (eighth, lst);
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_fifth, "fifth", 1, 0, 0,
(SCM lst),
"Return the fifth element of @var{lst}.")
#define FUNC_NAME s_scm_srfi1_fifth
SCM
scm_srfi1_fifth (SCM lst)
{
return scm_list_ref (lst, SCM_I_MAKINUM (4));
CACHE_VAR (fifth, "fifth");
return scm_call_1 (fifth, lst);
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
@ -1398,14 +1393,12 @@ SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
(SCM lst),
"Return the ninth element of @var{lst}.")
#define FUNC_NAME s_scm_srfi1_ninth
SCM
scm_srfi1_ninth (SCM lst)
{
return scm_list_ref (lst, scm_from_int (8));
CACHE_VAR (ninth, "ninth");
return scm_call_1 (ninth, lst);
}
#undef FUNC_NAME
SCM
scm_srfi1_not_pair_p (SCM obj)
@ -1696,24 +1689,19 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_seventh, "seventh", 1, 0, 0,
(SCM lst),
"Return the seventh element of @var{lst}.")
#define FUNC_NAME s_scm_srfi1_seventh
SCM
scm_srfi1_seventh (SCM lst)
{
return scm_list_ref (lst, scm_from_int (6));
CACHE_VAR (seventh, "seventh");
return scm_call_1 (seventh, lst);
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_sixth, "sixth", 1, 0, 0,
(SCM lst),
"Return the sixth element of @var{lst}.")
#define FUNC_NAME s_scm_srfi1_sixth
SCM
scm_srfi1_sixth (SCM lst)
{
return scm_list_ref (lst, scm_from_int (5));
CACHE_VAR (sixth, "sixth");
return scm_call_1 (sixth, lst);
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_span, "span", 2, 0, 0,
@ -1931,16 +1919,12 @@ SCM_DEFINE (scm_srfi1_take_while_x, "take-while!", 2, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
(SCM lst),
"Return the tenth element of @var{lst}.")
#define FUNC_NAME s_scm_srfi1_tenth
SCM
scm_srfi1_tenth (SCM lst)
{
return scm_list_ref (lst, scm_from_int (9));
CACHE_VAR (tenth, "tenth");
return scm_call_1 (tenth, lst);
}
#undef FUNC_NAME
SCM
scm_srfi1_xcons (SCM d, SCM a)

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

@ -964,7 +964,7 @@
;;
(with-test-prefix "eighth"
(pass-if-exception "() -1" exception:out-of-range
(pass-if-exception "() -1" exception:wrong-type-arg
(eighth '(a b c d e f g)))
(pass-if (eq? 'h (eighth '(a b c d e f g h))))
(pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
@ -974,7 +974,7 @@
;;
(with-test-prefix "fifth"
(pass-if-exception "() -1" exception:out-of-range
(pass-if-exception "() -1" exception:wrong-type-arg
(fifth '(a b c d)))
(pass-if (eq? 'e (fifth '(a b c d e))))
(pass-if (eq? 'e (fifth '(a b c d e f)))))
@ -1900,7 +1900,7 @@
;;
(with-test-prefix "ninth"
(pass-if-exception "() -1" exception:out-of-range
(pass-if-exception "() -1" exception:wrong-type-arg
(ninth '(a b c d e f g h)))
(pass-if (eq? 'i (ninth '(a b c d e f g h i))))
(pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
@ -2283,7 +2283,7 @@
;;
(with-test-prefix "seventh"
(pass-if-exception "() -1" exception:out-of-range
(pass-if-exception "() -1" exception:wrong-type-arg
(seventh '(a b c d e f)))
(pass-if (eq? 'g (seventh '(a b c d e f g))))
(pass-if (eq? 'g (seventh '(a b c d e f g h)))))
@ -2293,7 +2293,7 @@
;;
(with-test-prefix "sixth"
(pass-if-exception "() -1" exception:out-of-range
(pass-if-exception "() -1" exception:wrong-type-arg
(sixth '(a b c d e)))
(pass-if (eq? 'f (sixth '(a b c d e f))))
(pass-if (eq? 'f (sixth '(a b c d e f g)))))
@ -2578,7 +2578,7 @@
;;
(with-test-prefix "tenth"
(pass-if-exception "() -1" exception:out-of-range
(pass-if-exception "() -1" exception:wrong-type-arg
(tenth '(a b c d e f g h i)))
(pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
(pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))