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

This partially reverts commit 03731332d5dc8d650b947f5126427402c2b1d8bb
(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.

diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 27aa39e..5400814 100644 (file)
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -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."

diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 44db0e3..dc19dd2 100644 (file)
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -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)

diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index 909f58c..ca34e8f 100644 (file)
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -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)))))