summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/srfi/srfi-1.scm24
-rw-r--r--srfi/srfi-1.c69
-rw-r--r--test-suite/standalone/test-srfi-1.c32
3 files changed, 61 insertions, 64 deletions
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 <stdlib.h>
+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;
}