diff options
-rw-r--r-- | srfi/srfi-1.c | 70 | ||||
-rw-r--r-- | srfi/srfi-1.h | 2 | ||||
-rw-r--r-- | srfi/srfi-1.scm | 10 |
3 files changed, 72 insertions, 10 deletions
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 3a80b3162..6c1da2d7b 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -97,6 +97,76 @@ SCM_DEFINE (scm_srfi1_alist_copy, "alist-copy", 1, 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_t_trampoline_1 pred_tramp; + SCM ret, *p; + + pred_tramp = scm_trampoline_1 (pred); + SCM_ASSERT (pred_tramp, 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 (pred_tramp (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_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 upto, *p; + scm_t_trampoline_1 pred_tramp; + + pred_tramp = scm_trampoline_1 (pred); + SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME); + + p = &lst; + for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto)) + { + if (scm_is_true (pred_tramp (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_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0, (SCM lstlst), "Construct a list by appending all lists in @var{lstlst}.\n" diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h index 63896ed47..83f3da65f 100644 --- a/srfi/srfi-1.h +++ b/srfi/srfi-1.h @@ -33,6 +33,8 @@ #endif SCM_SRFI1_API SCM scm_srfi1_alist_copy (SCM alist); +SCM_SRFI1_API SCM scm_srfi1_break (SCM pred, SCM lst); +SCM_SRFI1_API SCM scm_srfi1_break_x (SCM pred, SCM lst); SCM_SRFI1_API SCM scm_srfi1_concatenate (SCM lstlst); SCM_SRFI1_API SCM scm_srfi1_concatenate_x (SCM lstlst); SCM_SRFI1_API SCM scm_srfi1_count (SCM pred, SCM list1, SCM rest); diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 24b0e0d5a..7e1fcf493 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -482,16 +482,6 @@ ;;; Searching -(define (break pred clist) - (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) - (break pred list)) ; XXX:optimize - (define (any pred ls . lists) (if (null? lists) (any1 pred ls) |