mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

srfi-1 partition!: move from C to Scheme

Browse source 
* libguile/srfi-1.c (scm_srfi1_partition_x): delete.
* libguile/srfi-1.h (scm_srfi1_partition_x): delete.
* module/srfi/srfi-1.scm: add partition!.
This commit is contained in:
Rob Browning 2024-07-17 22:18:05 -05:00
parent 925faf1f01
commit 3eb6afe738
3 changed files with 21 additions and 54 deletions
Download patch file Download diff file Expand all files Collapse all files

53
libguile/srfi-1.c
View file

@ -331,59 +331,6 @@ SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
(SCM pred, SCM lst),
"Split @var{lst} into those elements which do and don't satisfy\n"
"the predicate @var{pred}.\n"
"\n"
"The return is two values (@pxref{Multiple Values}), the first\n"
"being a list of all elements from @var{lst} which satisfy\n"
"@var{pred}, the second a list of those which do not.\n"
"\n"
"The elements in the result lists are in the same order as in\n"
"@var{lst} but the order in which the calls @code{(@var{pred}\n"
"elem)} are made on the list elements is unspecified.\n"
"\n"
"@var{lst} may be modified to construct the return lists.")
#define FUNC_NAME s_scm_srfi1_partition_x
{
SCM tlst, flst, *tp, *fp;
SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
/* tlst and flst are the lists of true and false elements. tp and fp are
where to store to append to them, initially &tlst and &flst, then
SCM_CDRLOC of the last pair in the respective lists. */
tlst = SCM_EOL;
flst = SCM_EOL;
tp = &tlst;
fp = &flst;
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
{
*tp = lst;
tp = SCM_CDRLOC (lst);
}
else
{
*fp = lst;
fp = SCM_CDRLOC (lst);
}
}
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
/* terminate whichever didn't get the last element(s) */
*tp = SCM_EOL;
*fp = SCM_EOL;
return scm_values_2 (tlst, flst);
}
#undef FUNC_NAME
void
scm_register_srfi_1 (void)

1
libguile/srfi-1.h
View file

@ -27,7 +27,6 @@
SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
SCM_INTERNAL void scm_register_srfi_1 (void);
SCM_INTERNAL void scm_init_srfi_1 (void);

21
module/srfi/srfi-1.scm
View file

@ -907,6 +907,27 @@ a common tail with @{list}."
(lp (cdr lst) (cdr lst) new-tail))))
(lp (cdr lst) last-kept tail))))))))
(define (partition! pred lst)
"Partition the elements of @var{list} with predicate @var{pred}.
Return two values: the list of elements satisfying @var{pred} and the
list of elements @emph{not} satisfying @var{pred}. The order of the
output lists follows the order of @var{list}. @var{list} is not
mutated. @var{lst} may be modified to construct the return lists."
(let ((matches (cons #f lst))
(mismatches (list #f)))
(let lp ((matches-next matches)
(mismatches-end mismatches))
(let ((next (cdr matches-next)))
(if (null? next)
(values (cdr matches) (cdr mismatches))
(let ((x (car next)))
(if (pred x)
(lp (cdr matches-next) mismatches-end)
(begin
(set-cdr! matches-next (cdr next))
(set-cdr! mismatches-end (list x))
(lp matches-next (cdr mismatches-end))))))))))
(define (remove! pred lst)
"Return a list containing all elements from @var{list} which do not
satisfy the predicate @var{pred}. The elements in the result list have