summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-05-05 23:07:23 +0200
committerAndy Wingo <wingo@pobox.com>2011-05-05 23:07:37 +0200
commita2230b653b86cece1daab09315873b5a4c592d6b (patch)
treea0a543c5d4a66f5fddb9d99600c55efd64ba0946
parente2ccab571e3e756b96b4179769b8fe8821bc28fd (diff)
downloadguile-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.
-rw-r--r--libguile/eval.c170
-rw-r--r--libguile/evalext.c5
-rw-r--r--libguile/srfi-1.c229
-rw-r--r--libguile/srfi-1.h2
-rw-r--r--module/ice-9/boot-9.scm185
-rw-r--r--module/srfi/srfi-1.scm129
-rw-r--r--test-suite/tests/eval.test15
7 files changed, 310 insertions, 425 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
diff --git a/libguile/evalext.c b/libguile/evalext.c
index ff2ff0ec0..1e5bd6822 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -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")
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. */
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 85aa65d0c..13ab067bd 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -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);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 294b91515..60d133f20 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -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))))))))
+
+
;;;
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 68b62de56..bcaca65d7 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -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))))
-
-;; Internal helper procedure. Map `f' over the single list `ls'.
-;;
-(define map1 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 . 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))))))))
+
+(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
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 7eb19ebec..9d6bc6d94 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -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)))
)))