Author: yamakenz
Date: Thu Jun 14 16:01:56 2007
New Revision: 4596
Modified:
sigscheme-trunk/src/module-srfi1.c
sigscheme-trunk/src/sigscheme.h
Log:
* src/sigscheme.h
- (scm_p_srfi1_find_tail): New function decl
* src/module-srfi1.c
- (scm_p_srfi1_drop): Clean up
- (scm_p_srfi1_last_pair): Fix broken non-pair object acceptance
- (scm_p_srfi1_find_tail): New function
- (compare_list): Removed
Modified: sigscheme-trunk/src/module-srfi1.c
==============================================================================
--- sigscheme-trunk/src/module-srfi1.c (original)
+++ sigscheme-trunk/src/module-srfi1.c Thu Jun 14 16:01:56 2007
@@ -43,6 +43,9 @@
#include <config.h>
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
/*=======================================
File Local Macro Definitions
=======================================*/
@@ -59,7 +62,6 @@
/*=======================================
File Local Function Declarations
=======================================*/
-static ScmObj compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2);
/*=======================================
Function Definitions
@@ -100,17 +102,19 @@
/*===========================================================================
Selectors
===========================================================================*/
+/* SRFI1: drop returns all but the first i elements of list x.
+ * x may be any value -- a proper, circular, or dotted list. */
SCM_EXPORT ScmObj
scm_p_srfi1_drop(ScmObj lst, ScmObj scm_idx)
{
- ScmObj ret = lst;
- scm_int_t idx = 0;
- scm_int_t i;
+ ScmObj ret;
+ scm_int_t idx, i;
DECLARE_FUNCTION("drop", procedure_fixed_2);
ENSURE_INT(scm_idx);
idx = SCM_INT_VALUE(scm_idx);
+ ret = lst;
for (i = 0; i < idx; i++) {
if (!CONSP(ret))
ERR_OBJ("illegal index is specified for", lst);
@@ -121,14 +125,14 @@
return ret;
}
+/* SRFI-1: last-pair returns the last pair in the non-empty, finite list
+ * pair. */
SCM_EXPORT ScmObj
scm_p_srfi1_last_pair(ScmObj lst)
{
DECLARE_FUNCTION("last-pair", procedure_fixed_1);
- /* sanity check */
- if (NULLP(lst))
- ERR_OBJ("non-empty, proper list is required but got", lst);
+ ENSURE_CONS(lst);
for (; CONSP(CDR(lst)); lst = CDR(lst))
;
@@ -153,4 +157,27 @@
ERR_OBJ("proper or circular list required but got", lst);
return (SCM_LISTLEN_PROPERP(len)) ? MAKE_INT(len) : SCM_FALSE;
+}
+
+/*===========================================================================
+ Searching
+===========================================================================*/
+SCM_EXPORT ScmObj
+scm_p_srfi1_find_tail(ScmObj pred, ScmObj lst)
+{
+ ScmObj tail, elm, rest, found;
+ DECLARE_FUNCTION("find-tail", procedure_fixed_2);
+
+ ENSURE_PROCEDURE(pred);
+
+ rest = lst;
+ FOR_EACH_PAIR (tail, rest) {
+ elm = CAR(tail);
+ found = scm_call(pred, LIST_1(elm));
+ if (TRUEP(found))
+ return tail;
+ }
+ CHECK_PROPER_LIST_TERMINATION(rest, lst);
+
+ return SCM_FALSE;
}
Modified: sigscheme-trunk/src/sigscheme.h
==============================================================================
--- sigscheme-trunk/src/sigscheme.h (original)
+++ sigscheme-trunk/src/sigscheme.h Thu Jun 14 16:01:56 2007
@@ -1679,6 +1679,7 @@
SCM_EXPORT ScmObj scm_p_srfi1_drop(ScmObj lst, ScmObj scm_idx);
SCM_EXPORT ScmObj scm_p_srfi1_last_pair(ScmObj lst);
SCM_EXPORT ScmObj scm_p_srfi1_lengthplus(ScmObj lst);
+SCM_EXPORT ScmObj scm_p_srfi1_find_tail(ScmObj pred, ScmObj lst);
#endif /* SCM_USE_SRFI1 */
/* module-srfi2.c */
