SRFI-1: Rewrite break' and break!' in Scheme.

This partially reverts commit 6e9f3c2676
(Tue May 3 2005).

* module/srfi/srfi-1.scm (break, break!): New procedures.

* srfi/srfi-1.c (scm_srfi1_break, scm_srfi1_break_x): Rewrite as
  proxies to the corresponding Scheme procedures.

* test-suite/standalone/test-srfi-1.c (failure): New function.
  (tests): Add `scm_srfi1_break' test.  Use `failure'.

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)

srfi/srfi-1.c

@@ -207,72 +207,19 @@ SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-
+SCM
-SCM_DEFINE (scm_srfi1_break, "break", 2, 0, 0,
+scm_srfi1_break (SCM pred, SCM lst)
-            (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 ret, *p;
+  CACHE_VAR (break_proc, "break");
-
+  return scm_call_2 (break_proc, pred, lst);
-  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));
 }
-#undef FUNC_NAME
 
-
+SCM
-SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
+scm_srfi1_break_x (SCM pred, SCM lst)
-            (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 upto, *p;
+  CACHE_VAR (break_x, "break!");
-
+  return scm_call_2 (break_x, pred, lst);
-  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));
 }
-#undef FUNC_NAME
-
 
 SCM
 scm_srfi1_car_plus_cdr (SCM pair)

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;
 }