Author: yamakenz
Date: Thu Jul 5 03:55:26 2007
New Revision: 4665
Modified:
sigscheme-trunk/lib/srfi-1.scm
sigscheme-trunk/src/module-srfi1.c
sigscheme-trunk/src/procedure.c
sigscheme-trunk/src/sigscheme.h
sigscheme-trunk/src/sigschemeinternal.h
Log:
* This commit add C version of SRFI-1 map, map-in-order
* src/sigscheme.h
- (scm_p_srfi1_map_in_order): New function decl
* src/sigschemeinternal.h
- (scm_map_single_arg, scm_map_multiple_args): New function decl
* src/procedure.c
- (ERRMSG_UNEVEN_MAP_ARGS): Modify message
- (map_single_arg): Rename to scm_map_single_arg()
- (scm_map_single_arg): Renamed from map_single_arg()
- (map_multiple_args): Rename to scm_map_multiple_args()
- (scm_map_multiple_args):
* Renamed from map_multiple_args()
* Add arg 'allow_uneven_lists' for SRFI-1 map and skip list length equality
check if it is true
* src/module-srfi1.c
- (scm_p_srfi1_map_in_order): New function
- (scm_initialize_srfi1): Overwrite srfi-1:map and map by map-in-order
* lib/srfi-1.scm
- (for-each): Refer map-in-order directly to allow C version of it
Modified: sigscheme-trunk/lib/srfi-1.scm
==============================================================================
--- sigscheme-trunk/lib/srfi-1.scm (original)
+++ sigscheme-trunk/lib/srfi-1.scm Thu Jul 5 03:55:26 2007
@@ -1037,10 +1037,9 @@
;; Added by yamaken 2007-06-15
(define for-each
- (let ((srfi-1:map map-in-order)) ;; preserve the implementation
- (lambda args
- (apply srfi-1:map args)
- #f)))
+ (lambda args
+ (apply map-in-order args)
+ #f))
;;; filter, remove, partition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Modified: sigscheme-trunk/src/module-srfi1.c
==============================================================================
--- sigscheme-trunk/src/module-srfi1.c (original)
+++ sigscheme-trunk/src/module-srfi1.c Thu Jul 5 03:55:26 2007
@@ -71,17 +71,14 @@
{
scm_require(SCMLIBDIR "/srfi-1.scm");
- scm_define_alias("srfi-1:map", "map");
scm_define_alias("srfi-1:for-each", "for-each");
scm_define_alias("srfi-1:member", "member");
scm_define_alias("srfi-1:assoc", "assoc");
#if 0
- /* Although SigScheme's map is faster than srfi-1.scm and in-order, it is
- * not conforming to SRFI-1 specification since it rejects unequal length
- * arguments. If you need to use the efficient C version of map and
- * for-each, evaluate (define map r5rs:map) and (define for-each
- * r5rs:for-each) in your code after (use srfi-1). */
+ /* Although SigScheme's R5RS map is faster than srfi-1.scm and in-order, it
+ * is not conforming to SRFI-1 specification since it rejects unequal
+ * length arguments. */
scm_define_alias("map-in-order", "r5rs:map");
scm_define_alias("map", "r5rs:map");
scm_define_alias("for-each", "r5rs:for-each");
@@ -90,6 +87,9 @@
/* Overwrite Scheme procedures with efficient C implementations. */
scm_register_funcs(scm_functable_srfi1);
+ scm_define_alias("srfi-1:map", "map-in-order");
+ scm_define_alias("map", "map-in-order");
+
scm_define_alias("proper-list?", "list?");
/* SigScheme's list-tail satisfies the specification of drop. */
scm_define_alias("drop", "list-tail");
@@ -152,6 +152,25 @@
return MAKE_INT(SCM_LISTLEN_DOTTED(len));
else /* if (SCM_LISTLEN_CIRCULARP(len)) */
return SCM_FALSE;
+}
+
+/*===========================================================================
+ Fold, unfold & map
+===========================================================================*/
+SCM_EXPORT ScmObj
+scm_p_srfi1_map_in_order(ScmObj proc, ScmObj args)
+{
+ DECLARE_FUNCTION("map-in-order", procedure_variadic_1);
+
+ if (NULLP(args))
+ ERR("wrong number of arguments");
+
+ /* fast path for single arg case */
+ if (NULLP(CDR(args)))
+ return scm_map_single_arg(proc, CAR(args));
+
+ /* multiple args case */
+ return scm_map_multiple_args(proc, args, scm_true);
}
/*===========================================================================
Modified: sigscheme-trunk/src/procedure.c
==============================================================================
--- sigscheme-trunk/src/procedure.c (original)
+++ sigscheme-trunk/src/procedure.c Thu Jul 5 03:55:26 2007
@@ -43,7 +43,7 @@
/*=======================================
File Local Macro Definitions
=======================================*/
-#define ERRMSG_UNEVEN_MAP_ARGS "uneven-length lists are passed as arguments"
+#define ERRMSG_UNEVEN_MAP_ARGS "unequal-length lists are passed as arguments"
/*=======================================
File Local Type Definitions
@@ -58,8 +58,6 @@
/*=======================================
File Local Function Declarations
=======================================*/
-static ScmObj map_single_arg(ScmObj proc, ScmObj lst);
-static ScmObj map_multiple_args(ScmObj proc, ScmObj lsts);
/*=======================================
Function Definitions
@@ -283,14 +281,14 @@
/* fast path for single arg case */
if (NULLP(CDR(args)))
- return map_single_arg(proc, CAR(args));
+ return scm_map_single_arg(proc, CAR(args));
/* multiple args case */
- return map_multiple_args(proc, args);
+ return scm_map_multiple_args(proc, args, scm_false);
}
-static ScmObj
-map_single_arg(ScmObj proc, ScmObj lst)
+SCM_EXPORT ScmObj
+scm_map_single_arg(ScmObj proc, ScmObj lst)
{
ScmQueue q;
ScmObj elm, ret;
@@ -307,8 +305,8 @@
return ret;
}
-static ScmObj
-map_multiple_args(ScmObj proc, ScmObj lsts)
+SCM_EXPORT ScmObj
+scm_map_multiple_args(ScmObj proc, ScmObj lsts, scm_bool allow_uneven_lists)
{
ScmQueue retq, argq;
ScmObj ret, elm, map_args, rest_lsts, lst;
@@ -338,6 +336,7 @@
finish:
#if SCM_STRICT_ARGCHECK
+ if (!allow_uneven_lists) {
/* R5RS: 6.4 Control features
* > If more than one list is given, then they must all be the same length.
* SigScheme rejects such user-error explicitly. */
@@ -348,6 +347,7 @@
ERR(ERRMSG_UNEVEN_MAP_ARGS);
}
NO_MORE_ARG(lsts);
+ }
#endif
return ret;
Modified: sigscheme-trunk/src/sigscheme.h
==============================================================================
--- sigscheme-trunk/src/sigscheme.h (original)
+++ sigscheme-trunk/src/sigscheme.h Thu Jul 5 03:55:26 2007
@@ -1677,6 +1677,7 @@
SCM_EXPORT ScmObj scm_p_srfi1_dotted_listp(ScmObj obj);
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_map_in_order(ScmObj proc, ScmObj args);
SCM_EXPORT ScmObj scm_p_srfi1_find_tail(ScmObj pred, ScmObj lst);
#endif /* SCM_USE_SRFI1 */
Modified: sigscheme-trunk/src/sigschemeinternal.h
==============================================================================
--- sigscheme-trunk/src/sigschemeinternal.h (original)
+++ sigscheme-trunk/src/sigschemeinternal.h Thu Jul 5 03:55:26 2007
@@ -735,6 +735,11 @@
/* error.c */
SCM_EXPORT void scm_init_error(void);
+/* procedure.c */
+SCM_EXPORT ScmObj scm_map_single_arg(ScmObj proc, ScmObj lst);
+SCM_EXPORT ScmObj scm_map_multiple_args(ScmObj proc, ScmObj lsts,
+ scm_bool allow_uneven_lists);
+
/* list.c */
SCM_EXPORT scm_int_t scm_finite_length(ScmObj lst);
