mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
This commit is contained in:
Andy Wingo
commit
5eb75b5de0
15 changed files with 15474 additions and 15766 deletions
|
|
@ -536,10 +536,10 @@ SCM_API void scm_async_tick (void);
|
|||
while (0)
|
||||
|
||||
/* SCM_ASYNC_TICK_WITH_CODE is only available to Guile itself */
|
||||
# define SCM_ASYNC_TICK_WITH_CODE(stmt) \
|
||||
# define SCM_ASYNC_TICK_WITH_CODE(thr, stmt) \
|
||||
do \
|
||||
{ \
|
||||
if (SCM_UNLIKELY (SCM_I_CURRENT_THREAD->pending_asyncs)) \
|
||||
if (SCM_UNLIKELY (thr->pending_asyncs)) \
|
||||
{ \
|
||||
stmt; \
|
||||
scm_async_click (); \
|
||||
|
|
|
|||
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")
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010
|
||||
/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010,2011
|
||||
* Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
|
|
@ -617,8 +617,32 @@ SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
|
|||
"returned.")
|
||||
#define FUNC_NAME s_scm_memq
|
||||
{
|
||||
SCM_VALIDATE_LIST (2, lst);
|
||||
return scm_c_memq (x, lst);
|
||||
SCM hare = lst, tortoise = lst;
|
||||
|
||||
while (scm_is_pair (hare))
|
||||
{
|
||||
if (scm_is_eq (SCM_CAR (hare), x))
|
||||
return hare;
|
||||
else
|
||||
hare = SCM_CDR (hare);
|
||||
|
||||
if (!scm_is_pair (hare))
|
||||
break;
|
||||
|
||||
if (scm_is_eq (SCM_CAR (hare), x))
|
||||
return hare;
|
||||
else
|
||||
hare = SCM_CDR (hare);
|
||||
|
||||
tortoise = SCM_CDR (tortoise);
|
||||
if (SCM_UNLIKELY (scm_is_eq (hare, tortoise)))
|
||||
break;
|
||||
}
|
||||
|
||||
if (SCM_LIKELY (scm_is_null (hare)))
|
||||
return SCM_BOOL_F;
|
||||
else
|
||||
scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list");
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -633,13 +657,32 @@ SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
|
|||
"returned.")
|
||||
#define FUNC_NAME s_scm_memv
|
||||
{
|
||||
SCM_VALIDATE_LIST (2, lst);
|
||||
for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
|
||||
SCM hare = lst, tortoise = lst;
|
||||
|
||||
while (scm_is_pair (hare))
|
||||
{
|
||||
if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
|
||||
return lst;
|
||||
if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x)))
|
||||
return hare;
|
||||
else
|
||||
hare = SCM_CDR (hare);
|
||||
|
||||
if (!scm_is_pair (hare))
|
||||
break;
|
||||
|
||||
if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x)))
|
||||
return hare;
|
||||
else
|
||||
hare = SCM_CDR (hare);
|
||||
|
||||
tortoise = SCM_CDR (tortoise);
|
||||
if (SCM_UNLIKELY (scm_is_eq (hare, tortoise)))
|
||||
break;
|
||||
}
|
||||
return SCM_BOOL_F;
|
||||
|
||||
if (SCM_LIKELY (scm_is_null (hare)))
|
||||
return SCM_BOOL_F;
|
||||
else
|
||||
scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list");
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
|
|||
#endif
|
||||
SCM *stack_limit = vp->stack_limit; /* stack limit address */
|
||||
|
||||
SCM dynstate = SCM_I_CURRENT_THREAD->dynamic_state;
|
||||
scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
|
||||
scm_t_int64 vm_cookie = vp->cookie++;
|
||||
|
||||
/* Internal variables */
|
||||
|
|
|
|||
|
|
@ -244,7 +244,7 @@
|
|||
RUN_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK)
|
||||
|
||||
#define VM_HANDLE_INTERRUPTS \
|
||||
SCM_ASYNC_TICK_WITH_CODE (SYNC_REGISTER ())
|
||||
SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
|
||||
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -1635,7 +1635,7 @@ VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
|
|||
wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n);
|
||||
NULLSTACK (2 * n);
|
||||
|
||||
scm_i_swap_with_fluids (wf, dynstate);
|
||||
scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
|
||||
scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
|
||||
NEXT;
|
||||
}
|
||||
|
|
@ -1645,7 +1645,7 @@ VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
|
|||
SCM wf;
|
||||
wf = scm_car (scm_i_dynwinds ());
|
||||
scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
|
||||
scm_i_swap_with_fluids (wf, dynstate);
|
||||
scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
|
@ -1655,7 +1655,7 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
|
|||
SCM fluids;
|
||||
|
||||
CHECK_UNDERFLOW ();
|
||||
fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
|
||||
fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
|
||||
if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
|
||||
|| ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
|
||||
{
|
||||
|
|
@ -1683,7 +1683,7 @@ VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
|
|||
SCM val, fluid, fluids;
|
||||
|
||||
POP2 (val, fluid);
|
||||
fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
|
||||
fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
|
||||
if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
|
||||
|| ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -156,25 +156,6 @@
|
|||
(set-current-module (resolve-module '(guile))))
|
||||
|
||||
(let ()
|
||||
;; Private version of and-map that handles multiple lists.
|
||||
(define and-map*
|
||||
(lambda (f first . rest)
|
||||
(or (null? first)
|
||||
(if (null? rest)
|
||||
(let andmap ((first first))
|
||||
(let ((x (car first)) (first (cdr first)))
|
||||
(if (null? first)
|
||||
(f x)
|
||||
(and (f x) (andmap first)))))
|
||||
(let andmap ((first first) (rest rest))
|
||||
(let ((x (car first))
|
||||
(xr (map car rest))
|
||||
(first (cdr first))
|
||||
(rest (map cdr rest)))
|
||||
(if (null? first)
|
||||
(apply f x xr)
|
||||
(and (apply f x xr) (andmap first rest)))))))))
|
||||
|
||||
(define-syntax define-expansion-constructors
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
|
|
@ -1747,7 +1728,13 @@
|
|||
((vector? x)
|
||||
(let ((old (vector->list x)))
|
||||
(let ((new (map f old)))
|
||||
(if (and-map* eq? old new) x (list->vector new)))))
|
||||
;; inlined and-map with two args
|
||||
(let lp ((l1 old) (l2 new))
|
||||
(if (null? l1)
|
||||
x
|
||||
(if (eq? (car l1) (car l2))
|
||||
(lp (cdr l1) (cdr l2))
|
||||
(list->vector new)))))))
|
||||
(else x))))))
|
||||
|
||||
;; lexical variables
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
)))
|
||||
|
||||
|
|
|
|||
|
|
@ -486,7 +486,10 @@
|
|||
(make-check
|
||||
(syntax-rules (-> error eof)
|
||||
((_ port (proc -> error))
|
||||
(decoding-error? port (proc port)))
|
||||
(if (eq? 'substitute
|
||||
(port-conversion-strategy port))
|
||||
(eq? (proc port) #\?)
|
||||
(decoding-error? port (proc port))))
|
||||
((_ port (proc -> eof))
|
||||
(eof-object? (proc port)))
|
||||
((_ port (proc -> char))
|
||||
|
|
@ -510,7 +513,8 @@
|
|||
((peek-char -> e1)
|
||||
(read-char -> e1))
|
||||
expected ...))))
|
||||
(test-decoding-error
|
||||
|
||||
(test-decoding-error*
|
||||
(syntax-rules ()
|
||||
((_ sequence encoding strategy (expected ...))
|
||||
(begin
|
||||
|
|
@ -532,56 +536,56 @@
|
|||
(u8-list->bytevector 'sequence))))
|
||||
(set-port-encoding! p encoding)
|
||||
(set-port-conversion-strategy! p strategy)
|
||||
(make-peek+read-checks p #f expected ...))))))))
|
||||
(make-peek+read-checks p #f expected
|
||||
...)))))))
|
||||
(test-decoding-error
|
||||
(syntax-rules ()
|
||||
((_ sequence encoding (expected ...))
|
||||
(begin
|
||||
(test-decoding-error* sequence encoding 'error
|
||||
(expected ...))
|
||||
|
||||
(test-decoding-error (255 65 66 67) "UTF-8" 'error
|
||||
;; `escape' should behave exactly like `error'.
|
||||
(test-decoding-error* sequence encoding 'escape
|
||||
(expected ...))
|
||||
|
||||
(test-decoding-error* sequence encoding 'substitute
|
||||
(expected ...)))))))
|
||||
|
||||
(test-decoding-error (255 65 66 67) "UTF-8"
|
||||
(error #\A #\B #\C eof))
|
||||
|
||||
(test-decoding-error (255 65 66 67) "UTF-8" 'escape
|
||||
;; `escape' should behave exactly like `error'.
|
||||
(error #\A #\B #\C eof))
|
||||
(test-decoding-error (255 206 187 206 188) "UTF-8"
|
||||
(error #\λ #\μ eof))
|
||||
|
||||
(test-decoding-error (255 206 187 206 188) "UTF-8" 'substitute
|
||||
(#\? #\λ #\μ eof))
|
||||
|
||||
(test-decoding-error (206 187 206) "UTF-8" 'error
|
||||
(test-decoding-error (206 187 206) "UTF-8"
|
||||
;; Unterminated sequence.
|
||||
(#\λ error eof))
|
||||
|
||||
(test-decoding-error (206 187 206) "UTF-8" 'substitute
|
||||
;; Unterminated sequence.
|
||||
(#\λ #\? eof))
|
||||
|
||||
;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
|
||||
;; of the "Conformance" chapter of Unicode 6.0.0.)
|
||||
|
||||
(test-decoding-error (#xc0 #x80 #x41) "UTF-8" 'error
|
||||
(test-decoding-error (#xc0 #x80 #x41) "UTF-8"
|
||||
(error ;; C0: should be in the C2..DF range
|
||||
error ;; 80: invalid
|
||||
#\A
|
||||
eof))
|
||||
|
||||
(test-decoding-error (#xc0 #x80 #x41) "UTF-8" 'substitute
|
||||
(#\? ;; C0: should be in the C2..DF range
|
||||
#\? ;; 80: invalid
|
||||
#\A
|
||||
eof))
|
||||
|
||||
(test-decoding-error (#xc2 #x41 #x42) "UTF-8" 'error
|
||||
(test-decoding-error (#xc2 #x41 #x42) "UTF-8"
|
||||
(error ;; 41: should be in the 80..BF range
|
||||
#\B
|
||||
eof))
|
||||
|
||||
(test-decoding-error (#xe0 #x88 #x88) "UTF-8" 'error
|
||||
(test-decoding-error (#xe0 #x88 #x88) "UTF-8"
|
||||
(error ;; 2nd byte should be in the A0..BF range
|
||||
eof))
|
||||
|
||||
(test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8" 'error
|
||||
(test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
|
||||
(error ;; 3rd byte should be in the 80..BF range
|
||||
#\B
|
||||
eof))
|
||||
|
||||
(test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8" 'error
|
||||
(test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
|
||||
(error ;; 2nd byte should be in the 90..BF range
|
||||
eof))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue