[Patch] Re-implement srfi-1 partition in C to avoid stack overflow

[Matthias Koeppe]

The partition procedure in srfi-1 does not work well in Guile.  Even
for not-very-long input lists (like 500 elements), a stack overflow is
signaled.  The reason seems to be the recursive use of receive and
values.

Here is the srfi/ChangeLog entry:

2003-06-19  Matthias Koeppe  <address@hidden>

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

Index: test-suite/tests/srfi-1.test
===================================================================
RCS file: /cvs/guile/guile-core/test-suite/tests/srfi-1.test,v
retrieving revision 1.2
diff -u -c -r1.2 srfi-1.test
*** test-suite/tests/srfi-1.test        12 May 2003 23:05:50 -0000      1.2
--- test-suite/tests/srfi-1.test        19 Jun 2003 15:52:41 -0000
***************
*** 183,185 ****
--- 183,229 ----
    (pass-if "'(a b . c) 2"
      (equal? '(a b)
            (take '(a b . c) 2))))
+ 
+ ;;
+ ;; partition
+ ;;
+ 
+ (define (test-partition pred list kept-good dropped-good)
+   (call-with-values (lambda ()
+                       (partition pred list))
+       (lambda (kept dropped)
+       (and (equal? kept kept-good)
+            (equal? dropped dropped-good)))))
+ 
+ (with-test-prefix "partition"
+                 
+   (pass-if "with dropped tail"
+     (test-partition even? '(1 2 3 4 5 6 7)
+                   '(2 4 6) '(1 3 5 7)))
+ 
+   (pass-if "with kept tail"
+     (test-partition even? '(1 2 3 4 5 6)
+                   '(2 4 6) '(1 3 5)))
+ 
+   (pass-if "with everything dropped"
+     (test-partition even? '(1 3 5 7)
+                   '() '(1 3 5 7)))
+ 
+   (pass-if "with everything kept"
+     (test-partition even? '(2 4 6)
+                   '(2 4 6) '()))
+ 
+   (pass-if "with empty list"
+     (test-partition even? '()
+                   '() '()))
+ 
+   (pass-if "with reasonably long list"
+     ;; the old implementation from SRFI-1 reference implementation
+     ;; would signal a stack-overflow for a list of only 500 elements!
+     (call-with-values (lambda ()
+                       (partition even?
+                                  (make-list 10000 1)))
+       (lambda (even odd)
+       (and (= (length odd) 10000)
+            (= (length even) 0))))))
+ 
Index: srfi/srfi-1.c
===================================================================
RCS file: /cvs/guile/guile-core/srfi/srfi-1.c,v
retrieving revision 1.6
diff -u -c -r1.6 srfi-1.c
*** srfi/srfi-1.c       21 Apr 2003 01:59:57 -0000      1.6
--- srfi/srfi-1.c       19 Jun 2003 15:52:41 -0000
***************
*** 319,324 ****
--- 319,364 ----
  }
  #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)
  {
Index: srfi/srfi-1.scm
===================================================================
RCS file: /cvs/guile/guile-core/srfi/srfi-1.scm,v
retrieving revision 1.24
diff -u -c -r1.24 srfi-1.scm
*** srfi/srfi-1.scm     12 May 2003 23:02:01 -0000      1.24
--- srfi/srfi-1.scm     19 Jun 2003 15:52:41 -0000
***************
*** 662,676 ****
  
  ;;; 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))
  
--- 662,667 ----


-- 
Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe