diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 54008146e..852729346 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -472,6 +472,30 @@ that result. See the manual for details." ;;; Searching +(define (break pred clist) + "Return two values, the longest initial prefix of LST whose elements +all fail the predicate PRED, and the remainder of LST." + (let lp ((clist clist) (rl '())) + (if (or (null? clist) + (pred (car clist))) + (values (reverse! rl) clist) + (lp (cdr clist) (cons (car clist) rl))))) + +(define (break! pred list) + "Linear-update variant of `break'." + (let loop ((l list) + (prev #f)) + (cond ((null? l) + (values list '())) + ((pred (car l)) + (if (pair? prev) + (begin + (set-cdr! prev '()) + (values list l)) + (values '() list))) + (else + (loop (cdr l) l))))) + (define (any pred ls . lists) (if (null? lists) (any1 pred ls) diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index dc19dd226..02c580d97 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -207,72 +207,19 @@ SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_break, "break", 2, 0, 0, - (SCM pred, SCM lst), - "Return two values, the longest initial prefix of @var{lst}\n" - "whose elements all fail the predicate @var{pred}, and the\n" - "remainder of @var{lst}.\n" - "\n" - "Note that the name @code{break} conflicts with the @code{break}\n" - "binding established by @code{while}. Applications wanting to\n" - "use @code{break} from within a @code{while} loop will need to\n" - "make a new define under a different name.") -#define FUNC_NAME s_scm_srfi1_break +SCM +scm_srfi1_break (SCM pred, SCM lst) { - SCM ret, *p; - - SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME); - - ret = SCM_EOL; - p = &ret; - for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) - { - SCM elem = SCM_CAR (lst); - if (scm_is_true (scm_call_1 (pred, elem))) - goto done; - - /* want this elem, tack it onto the end of ret */ - *p = scm_cons (elem, SCM_EOL); - p = SCM_CDRLOC (*p); - } - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); - - done: - return scm_values (scm_list_2 (ret, lst)); + CACHE_VAR (break_proc, "break"); + return scm_call_2 (break_proc, pred, lst); } -#undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0, - (SCM pred, SCM lst), - "Return two values, the longest initial prefix of @var{lst}\n" - "whose elements all fail the predicate @var{pred}, and the\n" - "remainder of @var{lst}. @var{lst} may be modified to form the\n" - "return.") -#define FUNC_NAME s_scm_srfi1_break_x +SCM +scm_srfi1_break_x (SCM pred, SCM lst) { - SCM upto, *p; - - SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME); - - p = &lst; - for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto)) - { - if (scm_is_true (scm_call_1 (pred, SCM_CAR (upto)))) - goto done; - - /* want this element */ - p = SCM_CDRLOC (upto); - } - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list"); - - done: - *p = SCM_EOL; - return scm_values (scm_list_2 (lst, upto)); + CACHE_VAR (break_x, "break!"); + return scm_call_2 (break_x, pred, lst); } -#undef FUNC_NAME - SCM scm_srfi1_car_plus_cdr (SCM pair) diff --git a/test-suite/standalone/test-srfi-1.c b/test-suite/standalone/test-srfi-1.c index 215008ddc..995c20e95 100644 --- a/test-suite/standalone/test-srfi-1.c +++ b/test-suite/standalone/test-srfi-1.c @@ -27,10 +27,18 @@ #include +static void +failure (const char *proc, SCM result) +{ + scm_simple_format (scm_current_error_port (), + scm_from_locale_string ("`~S' failed: ~S~%"), + scm_list_2 (scm_from_locale_symbol (proc), result)); +} + static void * tests (void *data) { - SCM times, lst, result; + SCM times, negative_p, lst, result; scm_init_srfi_1 (); @@ -41,9 +49,27 @@ tests (void *data) result = scm_srfi1_fold (times, scm_from_int (1), lst, scm_list_1 (lst)); if (scm_to_int (result) == 36) - * (int *) data = EXIT_SUCCESS; + { + negative_p = SCM_VARIABLE_REF (scm_c_lookup ("negative?")); + result = scm_srfi1_break (negative_p, + scm_list_3 (scm_from_int (1), + scm_from_int (2), + scm_from_int (-1))); + + if (SCM_VALUESP (result)) + /* There's no API to access the values, so assume this is OK. */ + * (int *) data = EXIT_SUCCESS; + else + { + failure ("break", result); + * (int *) data = EXIT_FAILURE; + } + } else - * (int *) data = EXIT_FAILURE; + { + failure ("fold", result); + * (int *) data = EXIT_FAILURE; + } return data; }