From a2230b653b86cece1daab09315873b5a4c592d6b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 5 May 2011 23:07:23 +0200 Subject: [PATCH] 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. --- libguile/eval.c | 170 +++------------------------ libguile/evalext.c | 5 +- libguile/srfi-1.c | 229 ------------------------------------- libguile/srfi-1.h | 2 - module/ice-9/boot-9.scm | 185 ++++++++++++++++++++++++++++++ module/srfi/srfi-1.scm | 129 ++++++++++++++++----- test-suite/tests/eval.test | 15 ++- 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))) ))) -- 2.20.1