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.
This commit is contained in:
Andy Wingo
parent
e2ccab571e
commit
a2230b653b
7 changed files with 309 additions and 424 deletions
170
libguile/eval.c
170
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;
|
||||
static SCM var = SCM_BOOL_F;
|
||||
|
||||
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);
|
||||
}
|
||||
if (scm_is_false (var))
|
||||
var = scm_private_variable (scm_the_root_module (),
|
||||
scm_from_latin1_symbol ("map"));
|
||||
|
||||
return scm_apply (scm_variable_ref (var),
|
||||
scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -55,9 +55,6 @@ SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_REGISTER_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);
|
||||
|
||||
|
||||
SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return #t for objects which Guile considers self-evaluating")
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -39,8 +39,6 @@ SCM_INTERNAL SCM scm_srfi1_find_tail (SCM pred, SCM lst);
|
|||
SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
|
||||
SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
|
||||
SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst);
|
||||
SCM_INTERNAL SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
|
||||
SCM_INTERNAL SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
|
||||
SCM_INTERNAL SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
|
||||
SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
|
||||
SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
|
||||
|
|
|
|||
|
|
@ -263,6 +263,50 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
|
||||
|
||||
|
||||
;;; Boot versions of `map' and `for-each', enough to get the expander
|
||||
;;; running.
|
||||
;;;
|
||||
(define map
|
||||
(case-lambda
|
||||
((f l)
|
||||
(let map1 ((l l))
|
||||
(if (null? l)
|
||||
'()
|
||||
(cons (f (car l)) (map1 (cdr l))))))
|
||||
((f l1 l2)
|
||||
(let map2 ((l1 l1) (l2 l2))
|
||||
(if (null? l1)
|
||||
'()
|
||||
(cons (f (car l1) (car l2))
|
||||
(map2 (cdr l1) (cdr l2))))))
|
||||
((f l1 . rest)
|
||||
(let lp ((l1 l1) (rest rest))
|
||||
(if (null? l1)
|
||||
'()
|
||||
(cons (apply f (car l1) (map car rest))
|
||||
(lp (cdr l1) (map cdr rest))))))))
|
||||
|
||||
(define for-each
|
||||
(case-lambda
|
||||
((f l)
|
||||
(let for-each1 ((l l))
|
||||
(if (pair? l)
|
||||
(begin
|
||||
(f (car l))
|
||||
(for-each1 (cdr l))))))
|
||||
((f l1 l2)
|
||||
(let for-each2 ((l1 l1) (l2 l2))
|
||||
(if (pair? l1)
|
||||
(begin
|
||||
(f (car l1) (car l2))
|
||||
(for-each2 (cdr l1) (cdr l2))))))
|
||||
((f l1 . rest)
|
||||
(let lp ((l1 l1) (rest rest))
|
||||
(if (pair? l1)
|
||||
(begin
|
||||
(apply f (car l1) (map car rest))
|
||||
(lp (cdr l1) (map cdr rest))))))))
|
||||
|
||||
;;; {and-map and or-map}
|
||||
;;;
|
||||
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
|
||||
|
|
@ -479,6 +523,147 @@ If there is no handler at all, Guile prints an error and then exits."
|
|||
(define sym
|
||||
(if (module-locally-bound? (current-module) 'sym) sym val)))))
|
||||
|
||||
;;; The real versions of `map' and `for-each', with cycle detection, and
|
||||
;;; that use reverse! instead of recursion in the case of `map'.
|
||||
;;;
|
||||
(define map
|
||||
(case-lambda
|
||||
((f l)
|
||||
(let map1 ((hare l) (tortoise l) (move? #f) (out '()))
|
||||
(if (pair? hare)
|
||||
(if move?
|
||||
(if (eq? tortoise hare)
|
||||
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
|
||||
(list l) #f)
|
||||
(map1 (cdr hare) (cdr tortoise) #f
|
||||
(cons (f (car hare)) out)))
|
||||
(map1 (cdr hare) tortoise #t
|
||||
(cons (f (car hare)) out)))
|
||||
(if (null? hare)
|
||||
(reverse! out)
|
||||
(scm-error 'wrong-type-arg "map" "Not a list: ~S"
|
||||
(list l) #f)))))
|
||||
|
||||
((f l1 l2)
|
||||
(let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
|
||||
(cond
|
||||
((pair? h1)
|
||||
(cond
|
||||
((not (pair? h2))
|
||||
(scm-error 'wrong-type-arg "map"
|
||||
(if (list? h2)
|
||||
"List of wrong length: ~S"
|
||||
"Not a list: ~S")
|
||||
(list l2) #f))
|
||||
((not move?)
|
||||
(map2 (cdr h1) (cdr h2) t1 t2 #t
|
||||
(cons (f (car h1) (car h2)) out)))
|
||||
((eq? t1 h1)
|
||||
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
|
||||
(list l1) #f))
|
||||
((eq? t2 h2)
|
||||
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
|
||||
(list l2) #f))
|
||||
(else
|
||||
(map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
|
||||
(cons (f (car h1) (car h2)) out)))))
|
||||
|
||||
((and (null? h1) (null? h2))
|
||||
(reverse! out))
|
||||
|
||||
((null? h1)
|
||||
(scm-error 'wrong-type-arg "map"
|
||||
(if (list? h2)
|
||||
"List of wrong length: ~S"
|
||||
"Not a list: ~S")
|
||||
(list l2) #f))
|
||||
(else
|
||||
(scm-error 'wrong-type-arg "map"
|
||||
"Not a list: ~S"
|
||||
(list l1) #f)))))
|
||||
|
||||
((f l1 . rest)
|
||||
(let ((len (length l1)))
|
||||
(let mapn ((rest rest))
|
||||
(or (null? rest)
|
||||
(if (= (length (car rest)) len)
|
||||
(mapn (cdr rest))
|
||||
(scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
|
||||
(list (car rest)) #f)))))
|
||||
(let mapn ((l1 l1) (rest rest) (out '()))
|
||||
(if (null? l1)
|
||||
(reverse! out)
|
||||
(mapn (cdr l1) (map cdr rest)
|
||||
(cons (apply f (car l1) (map car rest)) out)))))))
|
||||
|
||||
(define map-in-order map)
|
||||
|
||||
(define for-each
|
||||
(case-lambda
|
||||
((f l)
|
||||
(let for-each1 ((hare l) (tortoise l) (move? #f))
|
||||
(if (pair? hare)
|
||||
(if move?
|
||||
(if (eq? tortoise hare)
|
||||
(scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
|
||||
(list l) #f)
|
||||
(begin
|
||||
(f (car hare))
|
||||
(for-each1 (cdr hare) (cdr tortoise) #f)))
|
||||
(begin
|
||||
(f (car hare))
|
||||
(for-each1 (cdr hare) tortoise #t)))
|
||||
|
||||
(if (not (null? hare))
|
||||
(scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
|
||||
(list l) #f)))))
|
||||
|
||||
((f l1 l2)
|
||||
(let for-each2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f))
|
||||
(cond
|
||||
((and (pair? h1) (pair? h2))
|
||||
(cond
|
||||
((not move?)
|
||||
(f (car h1) (car h2))
|
||||
(for-each2 (cdr h1) (cdr h2) t1 t2 #t))
|
||||
((eq? t1 h1)
|
||||
(scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
|
||||
(list l1) #f))
|
||||
((eq? t2 h2)
|
||||
(scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
|
||||
(list l2) #f))
|
||||
(else
|
||||
(f (car h1) (car h2))
|
||||
(for-each2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f))))
|
||||
|
||||
((if (null? h1)
|
||||
(or (null? h2) (pair? h2))
|
||||
(and (pair? h1) (null? h2)))
|
||||
(if #f #f))
|
||||
|
||||
((list? h1)
|
||||
(scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
|
||||
(list h2) #f))
|
||||
(else
|
||||
(scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
|
||||
(list h1) #f)))))
|
||||
|
||||
((f l1 . rest)
|
||||
(let ((len (length l1)))
|
||||
(let for-eachn ((rest rest))
|
||||
(or (null? rest)
|
||||
(if (= (length (car rest)) len)
|
||||
(for-eachn (cdr rest))
|
||||
(scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
|
||||
(list (car rest)) #f)))))
|
||||
|
||||
(let for-eachn ((l1 l1) (rest rest))
|
||||
(if (pair? l1)
|
||||
(begin
|
||||
(apply f (car l1) (map car rest))
|
||||
(for-eachn (cdr l1) (map cdr rest))))))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -418,20 +418,20 @@ a list of those after."
|
|||
(let lp ((l (cons clist1 rest)) (acc '()))
|
||||
(if (any null? l)
|
||||
(reverse! acc)
|
||||
(lp (map1 cdr l) (cons (map1 car l) acc)))))
|
||||
(lp (map cdr l) (cons (map car l) acc)))))
|
||||
|
||||
|
||||
(define (unzip1 l)
|
||||
(map1 first l))
|
||||
(map first l))
|
||||
(define (unzip2 l)
|
||||
(values (map1 first l) (map1 second l)))
|
||||
(values (map first l) (map second l)))
|
||||
(define (unzip3 l)
|
||||
(values (map1 first l) (map1 second l) (map1 third l)))
|
||||
(values (map first l) (map second l) (map third l)))
|
||||
(define (unzip4 l)
|
||||
(values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
|
||||
(values (map first l) (map second l) (map third l) (map fourth l)))
|
||||
(define (unzip5 l)
|
||||
(values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
|
||||
(map1 fifth l)))
|
||||
(values (map first l) (map second l) (map third l) (map fourth l)
|
||||
(map fifth l)))
|
||||
|
||||
;;; Fold, unfold & map
|
||||
|
||||
|
|
@ -446,8 +446,8 @@ that result. See the manual for details."
|
|||
(let f ((knil knil) (lists (cons list1 rest)))
|
||||
(if (any null? lists)
|
||||
knil
|
||||
(let ((cars (map1 car lists))
|
||||
(cdrs (map1 cdr lists)))
|
||||
(let ((cars (map car lists))
|
||||
(cdrs (map cdr lists)))
|
||||
(f (apply kons (append! cars (list knil))) cdrs))))))
|
||||
|
||||
(define (fold-right kons knil clist1 . rest)
|
||||
|
|
@ -458,12 +458,12 @@ that result. See the manual for details."
|
|||
result
|
||||
(loop (cdr lst)
|
||||
(kons (car lst) result))))
|
||||
(let loop ((lists (map1 reverse (cons clist1 rest)))
|
||||
(let loop ((lists (map reverse (cons clist1 rest)))
|
||||
(result knil))
|
||||
(if (any1 null? lists)
|
||||
result
|
||||
(loop (map1 cdr lists)
|
||||
(apply kons (append! (map1 car lists) (list result))))))))
|
||||
(loop (map cdr lists)
|
||||
(apply kons (append! (map car lists) (list result))))))))
|
||||
|
||||
(define (pair-fold kons knil clist1 . rest)
|
||||
(if (null? rest)
|
||||
|
|
@ -475,7 +475,7 @@ that result. See the manual for details."
|
|||
(let f ((knil knil) (lists (cons clist1 rest)))
|
||||
(if (any null? lists)
|
||||
knil
|
||||
(let ((tails (map1 cdr lists)))
|
||||
(let ((tails (map cdr lists)))
|
||||
(f (apply kons (append! lists (list knil))) tails))))))
|
||||
|
||||
|
||||
|
|
@ -488,7 +488,7 @@ that result. See the manual for details."
|
|||
(let f ((lists (cons clist1 rest)))
|
||||
(if (any null? lists)
|
||||
knil
|
||||
(apply kons (append! lists (list (f (map1 cdr lists)))))))))
|
||||
(apply kons (append! lists (list (f (map cdr lists)))))))))
|
||||
|
||||
(define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
|
||||
(define (reverse+tail lst seed)
|
||||
|
|
@ -530,10 +530,79 @@ has just one element then that's the return value."
|
|||
ridentity
|
||||
(fold-right f (last lst) (drop-right lst 1))))
|
||||
|
||||
(define map
|
||||
(case-lambda
|
||||
((f l)
|
||||
(let map1 ((hare l) (tortoise l) (move? #f) (out '()))
|
||||
(if (pair? hare)
|
||||
(if move?
|
||||
(if (eq? tortoise hare)
|
||||
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
|
||||
(list l) #f)
|
||||
(map1 (cdr hare) (cdr tortoise) #f
|
||||
(cons (f (car hare)) out)))
|
||||
(map1 (cdr hare) tortoise #t
|
||||
(cons (f (car hare)) out)))
|
||||
(if (null? hare)
|
||||
(reverse! out)
|
||||
(scm-error 'wrong-type-arg "map" "Not a list: ~S"
|
||||
(list l) #f)))))
|
||||
|
||||
((f l1 . rest)
|
||||
(let ((len (fold (lambda (ls len)
|
||||
(let ((ls-len (length+ ls)))
|
||||
(if len
|
||||
(if ls-len (min ls-len len) len)
|
||||
ls-len)))
|
||||
(length+ l1)
|
||||
rest)))
|
||||
(if (not len)
|
||||
(scm-error 'wrong-type-arg "map"
|
||||
"Args do not contain a proper (finite) list: ~S"
|
||||
(list (cons l1 rest)) #f))
|
||||
(let mapn ((l1 l1) (rest rest) (len len) (out '()))
|
||||
(if (zero? len)
|
||||
(reverse! out)
|
||||
(mapn (cdr l1) (map cdr rest) (1- len)
|
||||
(cons (apply f (car l1) (map car rest)) out))))))))
|
||||
|
||||
;; Internal helper procedure. Map `f' over the single list `ls'.
|
||||
;;
|
||||
(define map1 map)
|
||||
(define for-each
|
||||
(case-lambda
|
||||
((f l)
|
||||
(let for-each1 ((hare l) (tortoise l) (move? #f))
|
||||
(if (pair? hare)
|
||||
(if move?
|
||||
(if (eq? tortoise hare)
|
||||
(scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
|
||||
(list l) #f)
|
||||
(begin
|
||||
(f (car hare))
|
||||
(for-each1 (cdr hare) (cdr tortoise) #f)))
|
||||
(begin
|
||||
(f (car hare))
|
||||
(for-each1 (cdr hare) tortoise #t)))
|
||||
|
||||
(if (not (null? hare))
|
||||
(scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
|
||||
(list l) #f)))))
|
||||
|
||||
((f l1 . rest)
|
||||
(let ((len (fold (lambda (ls len)
|
||||
(let ((ls-len (length+ ls)))
|
||||
(if len
|
||||
(if ls-len (min ls-len len) len)
|
||||
ls-len)))
|
||||
(length+ l1)
|
||||
rest)))
|
||||
(if (not len)
|
||||
(scm-error 'wrong-type-arg "for-each"
|
||||
"Args do not contain a proper (finite) list: ~S"
|
||||
(list (cons l1 rest)) #f))
|
||||
(let for-eachn ((l1 l1) (rest rest) (len len))
|
||||
(if (> len 0)
|
||||
(begin
|
||||
(apply f (car l1) (map car rest))
|
||||
(for-eachn (cdr l1) (map cdr rest) (1- len)))))))))
|
||||
|
||||
(define (append-map f clist1 . rest)
|
||||
(concatenate (apply map f clist1 rest)))
|
||||
|
|
@ -561,10 +630,10 @@ the list returned."
|
|||
(rl '()))
|
||||
(if (any1 null? l)
|
||||
(reverse! rl)
|
||||
(let ((res (apply proc (map1 car l))))
|
||||
(let ((res (apply proc (map car l))))
|
||||
(if res
|
||||
(lp (map1 cdr l) (cons res rl))
|
||||
(lp (map1 cdr l) rl)))))))
|
||||
(lp (map cdr l) (cons res rl))
|
||||
(lp (map cdr l) rl)))))))
|
||||
|
||||
(define (pair-for-each f clist1 . rest)
|
||||
(if (null? rest)
|
||||
|
|
@ -579,7 +648,7 @@ the list returned."
|
|||
(if #f #f)
|
||||
(begin
|
||||
(apply f l)
|
||||
(lp (map1 cdr l)))))))
|
||||
(lp (map cdr l)))))))
|
||||
|
||||
|
||||
;;; Searching
|
||||
|
|
@ -677,10 +746,10 @@ all fail the predicate PRED, and the remainder of LST."
|
|||
(let lp ((lists (cons ls lists)))
|
||||
(cond ((any1 null? lists)
|
||||
#f)
|
||||
((any1 null? (map1 cdr lists))
|
||||
(apply pred (map1 car lists)))
|
||||
((any1 null? (map cdr lists))
|
||||
(apply pred (map car lists)))
|
||||
(else
|
||||
(or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
|
||||
(or (apply pred (map car lists)) (lp (map cdr lists))))))))
|
||||
|
||||
(define (any1 pred ls)
|
||||
(let lp ((ls ls))
|
||||
|
|
@ -697,10 +766,10 @@ all fail the predicate PRED, and the remainder of LST."
|
|||
(let lp ((lists (cons ls lists)))
|
||||
(cond ((any1 null? lists)
|
||||
#t)
|
||||
((any1 null? (map1 cdr lists))
|
||||
(apply pred (map1 car lists)))
|
||||
((any1 null? (map cdr lists))
|
||||
(apply pred (map car lists)))
|
||||
(else
|
||||
(and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
|
||||
(and (apply pred (map car lists)) (lp (map cdr lists))))))))
|
||||
|
||||
(define (every1 pred ls)
|
||||
(let lp ((ls ls))
|
||||
|
|
@ -724,9 +793,9 @@ CLIST1 ... CLISTN, that satisfies PRED."
|
|||
(let lp ((lists (cons clist1 rest)) (i 0))
|
||||
(cond ((any1 null? lists)
|
||||
#f)
|
||||
((apply pred (map1 car lists)) i)
|
||||
((apply pred (map car lists)) i)
|
||||
(else
|
||||
(lp (map1 cdr lists) (+ i 1)))))))
|
||||
(lp (map cdr lists) (+ i 1)))))))
|
||||
|
||||
;;; Association lists
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
|
||||
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -28,6 +28,11 @@
|
|||
(define exception:failed-match
|
||||
(cons 'syntax-error "failed to match any pattern"))
|
||||
|
||||
(define exception:not-a-list
|
||||
(cons 'wrong-type-arg "Not a list"))
|
||||
|
||||
(define exception:wrong-length
|
||||
(cons 'wrong-type-arg "wrong length"))
|
||||
|
||||
;;;
|
||||
;;; miscellaneous
|
||||
|
|
@ -192,19 +197,19 @@
|
|||
(with-test-prefix "different length lists"
|
||||
|
||||
(pass-if-exception "first list empty"
|
||||
exception:out-of-range
|
||||
exception:wrong-length
|
||||
(map + '() '(1)))
|
||||
|
||||
(pass-if-exception "second list empty"
|
||||
exception:out-of-range
|
||||
exception:wrong-length
|
||||
(map + '(1) '()))
|
||||
|
||||
(pass-if-exception "first list shorter"
|
||||
exception:out-of-range
|
||||
exception:wrong-length
|
||||
(map + '(1) '(2 3)))
|
||||
|
||||
(pass-if-exception "second list shorter"
|
||||
exception:out-of-range
|
||||
exception:wrong-length
|
||||
(map + '(1 2) '(3)))
|
||||
)))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue