2003-07-14 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>

	* srfi-1.c, srfi-1.h (scm_srfi1_partition), srfi-1.scm (partition):
	Re-implement in C to avoid stack overflows for long input lists.

diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 5fe78c7..247e0c3 100644 (file)
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -620,6 +620,46 @@ SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
+           (SCM pred, SCM list),
+           "Partition the elements of @var{list} with predicate @var{pred}.\n"
+           "Return two values: the list of elements satifying @var{pred} and\n"
+           "the list of elements @emph{not} satisfying @var{pred}.  The order\n"
+           "of the output lists follows the order of @var{list}.  @var{list}\n"
+           "is not mutated.  One of the output lists may share memory with @var{list}.\n")
+#define FUNC_NAME s_scm_srfi1_partition
+{
+  /* In this implementation, the output lists don't share memory with
+     list, because it's probably not worth the effort. */
+  scm_t_trampoline_1 call = scm_trampoline_1(pred);
+  SCM kept = scm_cons(SCM_EOL, SCM_EOL);
+  SCM kept_tail = kept;
+  SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
+  SCM dropped_tail = dropped;
+  
+  SCM_ASSERT(call, pred, 2, FUNC_NAME);
+  
+  for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
+    SCM elt = SCM_CAR(list);
+    SCM new_tail = scm_cons(SCM_CAR(list), SCM_EOL);
+    if (SCM_NFALSEP(call(pred, elt))) {
+      SCM_SETCDR(kept_tail, new_tail);
+      kept_tail = new_tail;
+    }
+    else {
+      SCM_SETCDR(dropped_tail, new_tail);
+      dropped_tail = new_tail;
+    }
+  }
+  /* re-use the initial conses for the values list */
+  SCM_SETCAR(kept, SCM_CDR(kept));
+  SCM_SETCDR(kept, dropped);
+  SCM_SETCAR(dropped, SCM_CDR(dropped));
+  SCM_SETCDR(dropped, SCM_EOL);
+  return scm_values(kept);
+}
+#undef FUNC_NAME
+
 void
 scm_init_srfi_1 (void)
 {

diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h
index 79b3369..e082ba4 100644 (file)
--- a/srfi/srfi-1.h
+++ b/srfi/srfi-1.h
@@ -40,6 +40,7 @@ SCM_SRFI1_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
 SCM_SRFI1_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
 SCM_SRFI1_API SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred);
 SCM_SRFI1_API SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_partition (SCM pred, SCM list);
 
 SCM_SRFI1_API void scm_init_srfi_1 (void);
 

diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index 12d2d18..4b3b091 100644 (file)
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -662,15 +662,6 @@
 
 ;;; Filtering & partitioning
 
-(define (partition pred list)
-  (if (null? list)
-    (values '() '())
-    (if (pred (car list))
-      (receive (in out) (partition pred (cdr list))
-              (values (cons (car list) in) out))
-      (receive (in out) (partition pred (cdr list))
-              (values in (cons (car list) out))))))
-
 (define (remove pred list)
   (filter (lambda (x) (not (pred x))) list))