diff options
author | Andy Wingo <wingo@pobox.com> | 2011-05-05 23:07:23 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-05-05 23:07:37 +0200 |
commit | a2230b653b86cece1daab09315873b5a4c592d6b (patch) | |
tree | a0a543c5d4a66f5fddb9d99600c55efd64ba0946 /libguile/srfi-1.c | |
parent | e2ccab571e3e756b96b4179769b8fe8821bc28fd (diff) | |
download | guile-a2230b653b86cece1daab09315873b5a4c592d6b.tar.gz |
map and for-each in scheme
* module/ice-9/boot-9.scm (map, for-each): Implement in Scheme instead
of C. There are boot versions before `cond' is defined.
(map-in-order): Define this alias here instead of in evalext.h.
* libguile/eval.c: Stub out the map and for-each definitions to just
call into Scheme.
* libguile/evalext.c: Remove map-in-order definition.
* module/srfi/srfi-1.scm: Replace all calls to map1 with calls to map.
(map, for-each): Define implementations here, in Scheme, instead of in
C.
* test-suite/tests/eval.test (exception:wrong-length, "map"): Update the
expected exception for mapping over lists of different lengths.
* libguile/srfi-1.h:
* libguile/srfi-1.c: Remove map and for-each definitions. Remove the
bit that extended the core `map' primitive with another method: the
right way to do that is with modules.
Diffstat (limited to 'libguile/srfi-1.c')
-rw-r--r-- | libguile/srfi-1.c | 229 |
1 files changed, 0 insertions, 229 deletions
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index f67e60082..37441f788 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -44,32 +44,6 @@ */ -static long -srfi1_ilength (SCM sx) -{ - long i = 0; - SCM tortoise = sx; - SCM hare = sx; - - do { - if (SCM_NULL_OR_NIL_P(hare)) return i; - if (!scm_is_pair (hare)) return -2; - hare = SCM_CDR(hare); - i++; - if (SCM_NULL_OR_NIL_P(hare)) return i; - if (!scm_is_pair (hare)) return -2; - hare = SCM_CDR(hare); - i++; - /* For every two steps the hare takes, the tortoise takes one. */ - tortoise = SCM_CDR(tortoise); - } - while (! scm_is_eq (hare, tortoise)); - - /* If the tortoise ever catches the hare, then the list must contain - a cycle. */ - return -1; -} - static SCM equal_trampoline (SCM proc, SCM arg1, SCM arg2) { @@ -760,202 +734,6 @@ SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1, #undef FUNC_NAME -/* Typechecking for multi-argument MAP and FOR-EACH. - - Verify that each element of the vector ARGV, except for the first, - is a list and return minimum length. Attribute errors to WHO, - and claim that the i'th element of ARGV is WHO's i+2'th argument. */ -static inline int -check_map_args (SCM argv, - long len, - SCM gf, - SCM proc, - SCM args, - const char *who) -{ - long i; - SCM elt; - - for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--) - { - long elt_len; - elt = SCM_SIMPLE_VECTOR_REF (argv, i); - - if (!(scm_is_null (elt) || scm_is_pair (elt))) - goto check_map_error; - - elt_len = srfi1_ilength (elt); - if (elt_len < -1) - goto check_map_error; - - if (len < 0 || (elt_len >= 0 && elt_len < len)) - len = elt_len; - } - - if (len < 0) - { - /* i == 0 */ - elt = SCM_EOL; - check_map_error: - if (gf) - scm_apply_generic (gf, scm_cons (proc, args)); - else - scm_wrong_type_arg (who, i + 2, elt); - } - - scm_remember_upto_here_1 (argv); - return len; -} - - -SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map); - -/* Note: Currently, scm_srfi1_map applies PROC to the argument list(s) - sequentially, starting with the first element(s). This is used in - the Scheme procedure `map-in-order', which guarantees sequential - behaviour, is implemented using scm_map. If the behaviour changes, - we need to update `map-in-order'. -*/ - -SCM -scm_srfi1_map (SCM proc, SCM arg1, SCM args) -#define FUNC_NAME s_srfi1_map -{ - long i, len; - SCM res = SCM_EOL; - SCM *pres = &res; - - len = srfi1_ilength (arg1); - SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1, - g_srfi1_map, - scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map); - SCM_VALIDATE_REST_ARGUMENT (args); - if (scm_is_null (args)) - { - SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_srfi1_map, - proc, arg1, SCM_ARG1, s_srfi1_map); - SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map); - while (SCM_NIMP (arg1)) - { - *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1))); - pres = SCM_CDRLOC (*pres); - arg1 = SCM_CDR (arg1); - } - return res; - } - if (scm_is_null (SCM_CDR (args))) - { - SCM arg2 = SCM_CAR (args); - int len2 = srfi1_ilength (arg2); - SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_srfi1_map, - scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map); - if (len < 0 || (len2 >= 0 && len2 < len)) - len = len2; - SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2)) - && len >= 0 && len2 >= -1, - g_srfi1_map, - scm_cons2 (proc, arg1, args), - len2 >= 0 ? SCM_ARG2 : SCM_ARG3, - s_srfi1_map); - while (len > 0) - { - *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2))); - pres = SCM_CDRLOC (*pres); - arg1 = SCM_CDR (arg1); - arg2 = SCM_CDR (arg2); - --len; - } - return res; - } - args = scm_vector (arg1 = scm_cons (arg1, args)); - len = check_map_args (args, len, g_srfi1_map, proc, arg1, s_srfi1_map); - while (len > 0) - { - arg1 = SCM_EOL; - for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--) - { - SCM elt = SCM_SIMPLE_VECTOR_REF (args, i); - arg1 = scm_cons (SCM_CAR (elt), arg1); - SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt)); - } - *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL)); - pres = SCM_CDRLOC (*pres); - --len; - } - return res; -} -#undef FUNC_NAME - -SCM_REGISTER_PROC (s_srfi1_map_in_order, "map-in-order", 2, 0, 1, scm_srfi1_map); - -SCM_GPROC (s_srfi1_for_each, "for-each", 2, 0, 1, scm_srfi1_for_each, g_srfi1_for_each); - -SCM -scm_srfi1_for_each (SCM proc, SCM arg1, SCM args) -#define FUNC_NAME s_srfi1_for_each -{ - long i, len; - len = srfi1_ilength (arg1); - SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1, - g_srfi1_for_each, scm_cons2 (proc, arg1, args), - SCM_ARG2, s_srfi1_for_each); - SCM_VALIDATE_REST_ARGUMENT (args); - if (scm_is_null (args)) - { - SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_srfi1_for_each, - proc, arg1, SCM_ARG1, s_srfi1_for_each); - SCM_GASSERT2 (len >= 0, g_srfi1_for_each, proc, arg1, - SCM_ARG2, s_srfi1_map); - while (SCM_NIMP (arg1)) - { - scm_call_1 (proc, SCM_CAR (arg1)); - arg1 = SCM_CDR (arg1); - } - return SCM_UNSPECIFIED; - } - if (scm_is_null (SCM_CDR (args))) - { - SCM arg2 = SCM_CAR (args); - int len2 = srfi1_ilength (arg2); - SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_srfi1_for_each, - scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each); - if (len < 0 || (len2 >= 0 && len2 < len)) - len = len2; - SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2)) - && len >= 0 && len2 >= -1, - g_srfi1_for_each, - scm_cons2 (proc, arg1, args), - len2 >= 0 ? SCM_ARG2 : SCM_ARG3, - s_srfi1_for_each); - while (len > 0) - { - scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)); - arg1 = SCM_CDR (arg1); - arg2 = SCM_CDR (arg2); - --len; - } - return SCM_UNSPECIFIED; - } - args = scm_vector (arg1 = scm_cons (arg1, args)); - len = check_map_args (args, len, g_srfi1_for_each, proc, arg1, - s_srfi1_for_each); - while (len > 0) - { - arg1 = SCM_EOL; - for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--) - { - SCM elt = SCM_SIMPLE_VECTOR_REF (args, i); - arg1 = scm_cons (SCM_CAR (elt), arg1); - SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt)); - } - scm_apply (proc, arg1, SCM_EOL); - --len; - } - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0, (SCM key, SCM alist, SCM pred), "Behaves like @code{assq} but uses third argument @var{pred?}\n" @@ -1175,16 +953,9 @@ scm_register_srfi_1 (void) void scm_init_srfi_1 (void) { - SCM the_root_module = scm_lookup_closure_module (SCM_BOOL_F); #ifndef SCM_MAGIC_SNARFER #include "libguile/srfi-1.x" #endif - scm_c_extend_primitive_generic - (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "map")), - SCM_VARIABLE_REF (scm_c_lookup ("map"))); - scm_c_extend_primitive_generic - (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "for-each")), - SCM_VARIABLE_REF (scm_c_lookup ("for-each"))); } /* End of srfi-1.c. */ |