diff options
author | Andy Wingo <wingo@pobox.com> | 2011-05-06 00:18:52 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-05-06 00:18:52 +0200 |
commit | 5eb75b5de08ea8eb86a4760e1454460b61b4bccc (patch) | |
tree | 55efc5ec0ed5bf42cfafd7249637d96cb4818ef3 /libguile/eval.c | |
parent | 891a1851a1e0e47560cf99cf76e9478d77e1a7db (diff) | |
parent | a2a6c0e319b5c146c484cb1fe8ffc9b14b9a9876 (diff) | |
download | guile-5eb75b5de08ea8eb86a4760e1454460b61b4bccc.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Diffstat (limited to 'libguile/eval.c')
-rw-r--r-- | libguile/eval.c | 170 |
1 files changed, 15 insertions, 155 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index f830e0099..009f3790b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -596,171 +596,31 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, #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 proper list whose length is LEN. Attribute errors to WHO, - and claim that the i'th element of ARGV is WHO's i+2'th argument. */ -static inline void -check_map_args (SCM argv, - long len, - SCM gf, - SCM proc, - SCM args, - const char *who) -{ - long i; - - for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--) - { - SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i); - long elt_len = scm_ilength (elt); - - if (elt_len < 0) - { - if (gf) - scm_apply_generic (gf, scm_cons (proc, args)); - else - scm_wrong_type_arg (who, i + 2, elt); - } - - if (elt_len != len) - scm_out_of_range_pos (who, elt, scm_from_long (i + 2)); - } -} - - -SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map); - -/* Note: Currently, scm_map applies PROC to the argument list(s) - sequentially, starting with the first element(s). This is used in - evalext.c where 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_map (SCM proc, SCM arg1, SCM args) -#define FUNC_NAME s_map { - long i, len; - SCM res = SCM_EOL; - SCM *pres = &res; - - len = scm_ilength (arg1); - SCM_GASSERTn (len >= 0, - g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map); - SCM_VALIDATE_REST_ARGUMENT (args); - if (scm_is_null (args)) - { - SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_map, proc, arg1, SCM_ARG1, s_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 = scm_ilength (arg2); - SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_map, - scm_cons2 (proc, arg1, args), SCM_ARG1, s_map); - SCM_GASSERTn (len2 >= 0, - g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map); - if (len2 != len) - SCM_OUT_OF_RANGE (3, arg2); - while (SCM_NIMP (arg1)) - { - *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); - } - return res; - } - arg1 = scm_cons (arg1, args); - args = scm_vector (arg1); - check_map_args (args, len, g_map, proc, arg1, s_map); - while (1) - { - arg1 = SCM_EOL; - for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--) - { - SCM elt = SCM_SIMPLE_VECTOR_REF (args, i); - if (SCM_IMP (elt)) - return res; - 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); - } -} -#undef FUNC_NAME + static SCM var = SCM_BOOL_F; + if (scm_is_false (var)) + var = scm_private_variable (scm_the_root_module (), + scm_from_latin1_symbol ("map")); -SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each); + return scm_apply (scm_variable_ref (var), + scm_cons (proc, scm_cons (arg1, args)), SCM_EOL); +} SCM scm_for_each (SCM proc, SCM arg1, SCM args) -#define FUNC_NAME s_for_each { - long i, len; - len = scm_ilength (arg1); - SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), - SCM_ARG2, s_for_each); - SCM_VALIDATE_REST_ARGUMENT (args); - if (scm_is_null (args)) - { - SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_for_each, - proc, arg1, SCM_ARG1, s_for_each); - 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 = scm_ilength (arg2); - SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_for_each, - scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each); - SCM_GASSERTn (len2 >= 0, g_for_each, - scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each); - if (len2 != len) - SCM_OUT_OF_RANGE (3, arg2); - while (SCM_NIMP (arg1)) - { - scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)); - arg1 = SCM_CDR (arg1); - arg2 = SCM_CDR (arg2); - } - return SCM_UNSPECIFIED; - } - arg1 = scm_cons (arg1, args); - args = scm_vector (arg1); - check_map_args (args, len, g_for_each, proc, arg1, s_for_each); - while (1) - { - arg1 = SCM_EOL; - for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--) - { - SCM elt = SCM_SIMPLE_VECTOR_REF (args, i); - if (SCM_IMP (elt)) - return SCM_UNSPECIFIED; - arg1 = scm_cons (SCM_CAR (elt), arg1); - SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt)); - } - scm_apply (proc, arg1, SCM_EOL); - } + static SCM var = SCM_BOOL_F; + + if (scm_is_false (var)) + var = scm_private_variable (scm_the_root_module (), + scm_from_latin1_symbol ("for-each")); + + return scm_apply (scm_variable_ref (var), + scm_cons (proc, scm_cons (arg1, args)), SCM_EOL); } -#undef FUNC_NAME static SCM |