diff --git a/benchmark-suite/benchmarks/srfi-1.bm b/benchmark-suite/benchmarks/srfi-1.bm index e07d3b95f..835608d41 100644 --- a/benchmark-suite/benchmarks/srfi-1.bm +++ b/benchmark-suite/benchmarks/srfi-1.bm @@ -36,3 +36,12 @@ (benchmark "small" 2000000 (fold (lambda (x y) y) #f %small-list))) + + +(with-benchmark-prefix "drop-while" + + (benchmark "big" 30 + (drop-while (lambda (n) #t) %big-list)) + + (benchmark "small" 2000000 + (drop-while (lambda (n) #t) %small-list))) diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 852729346..1e27d6f91 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -350,6 +350,30 @@ end-of-list checking in contexts where dotted lists are allowed." (define take list-head) (define drop list-tail) +(define (take! lst i) + "Linear-update variant of `take'." + (if (= i 0) + '() + (let ((tail (drop lst (- i 1)))) + (set-cdr! tail '()) + lst))) + +(define (drop-right! lst i) + "Linear-update variant of `drop-right'." + (let ((tail (drop lst i))) + (if (null? tail) + '() + (let loop ((prev lst) + (tail (cdr tail))) + (if (null? tail) + (if (pair? prev) + (begin + (set-cdr! prev '()) + lst) + lst) + (loop (cdr prev) + (cdr tail))))))) + (define (last pair) "Return the last element of the non-empty, finite list PAIR." (car (last-pair pair))) @@ -441,6 +465,24 @@ that result. See the manual for details." lis (uf (g seed) (cons (f seed) lis))))) +(define (reduce f ridentity lst) + "`reduce' is a variant of `fold', where the first call to F is on two +elements from LST, rather than one element and a given initial value. +If LST is empty, RIDENTITY is returned. If LST has just one element +then that's the return value." + (if (null? lst) + ridentity + (fold f (car lst) (cdr lst)))) + +(define (reduce-right f ridentity lst) + "`reduce-right' is a variant of `fold-right', where the first call to +F is on two elements from LST, rather than one element and a given +initial value. If LST is empty, RIDENTITY is returned. If LST +has just one element then that's the return value." + (if (null? lst) + ridentity + (fold-right f (last lst) (drop-right lst 1)))) + ;; Internal helper procedure. Map `f' over the single list `ls'. ;; @@ -470,8 +512,72 @@ that result. See the manual for details." (apply f l) (lp (map1 cdr l))))))) + ;;; Searching +(define (take-while pred ls) + "Return a new list which is the longest initial prefix of LS whose +elements all satisfy the predicate PRED." + (cond ((null? ls) '()) + ((not (pred (car ls))) '()) + (else + (let ((result (list (car ls)))) + (let lp ((ls (cdr ls)) (p result)) + (cond ((null? ls) result) + ((not (pred (car ls))) result) + (else + (set-cdr! p (list (car ls))) + (lp (cdr ls) (cdr p))))))))) + +(define (take-while! pred lst) + "Linear-update variant of `take-while'." + (let loop ((prev #f) + (rest lst)) + (cond ((null? rest) + lst) + ((pred (car rest)) + (loop rest (cdr rest))) + (else + (if (pair? prev) + (begin + (set-cdr! prev '()) + lst) + '()))))) + +(define (drop-while pred lst) + "Drop the longest initial prefix of LST whose elements all satisfy the +predicate PRED." + (let loop ((lst lst)) + (cond ((null? lst) + '()) + ((pred (car lst)) + (loop (cdr lst))) + (else lst)))) + +(define (span pred lst) + "Return two values, the longest initial prefix of LST whose elements +all satisfy the predicate PRED, and the remainder of LST." + (let lp ((lst lst) (rl '())) + (if (and (not (null? lst)) + (pred (car lst))) + (lp (cdr lst) (cons (car lst) rl)) + (values (reverse! rl) lst)))) + +(define (span! pred list) + "Linear-update variant of `span'." + (let loop ((prev #f) + (rest list)) + (cond ((null? rest) + (values list '())) + ((pred (car rest)) + (loop rest (cdr rest))) + (else + (if (pair? prev) + (begin + (set-cdr! prev '()) + (values list rest)) + (values '() list)))))) + (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." @@ -587,6 +693,27 @@ CLIST1 ... CLISTN, that satisfies PRED." (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r)) (lp (car r) (cdr r))))))) +;; It's not quite clear if duplicates among the `rest' elements are meant to +;; be cast out. The spec says `=' is called as (= lstelem restelem), +;; suggesting perhaps not, but the reference implementation shows the "list" +;; at each stage as including those elements already added. The latter +;; corresponds to what's described for lset-union, so that's what's done. +;; +(define (lset-adjoin = list . rest) + "Add to LIST any of the elements of REST not already in the list. +These elements are `cons'ed onto the start of LIST (so the return shares +a common tail with LIST), but the order they're added is unspecified. + +The given `=' procedure is used for comparing elements, called +as `(@var{=} listelem elem)', i.e., the second argument is one of the +given REST parameters." + (let lp ((l rest) (acc list)) + (if (null? l) + acc + (if (member (car l) acc (lambda (x y) (= y x))) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc)))))) + (define (lset-union = . rest) (let ((acc '())) (for-each (lambda (lst) diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 02c580d97..b81c90544 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -683,52 +683,19 @@ SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_drop_right_x, "drop-right!", 2, 0, 0, - (SCM lst, SCM n), - "Return the a list containing the @var{n} last elements of\n" - "@var{lst}. @var{lst} may be modified to build the return.") -#define FUNC_NAME s_scm_srfi1_drop_right_x +SCM +scm_srfi1_drop_right_x (SCM lst, SCM n) { - SCM tail, *p; - - if (scm_is_eq (n, SCM_INUM0)) - return lst; - - tail = scm_list_tail (lst, n); - p = &lst; - - /* p and tail work along the list, p being the cdrloc of the cell n steps - behind tail */ - for ( ; scm_is_pair (tail); tail = SCM_CDR (tail)) - p = SCM_CDRLOC (*p); - - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list"); - - *p = SCM_EOL; - return lst; + CACHE_VAR (drop_right_x, "drop-right!"); + return scm_call_2 (drop_right_x, lst, n); } -#undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_drop_while, "drop-while", 2, 0, 0, - (SCM pred, SCM lst), - "Drop the longest initial prefix of @var{lst} whose elements all\n" - "satisfy the predicate @var{pred}.") -#define FUNC_NAME s_scm_srfi1_drop_while +SCM +scm_srfi1_drop_while (SCM pred, SCM lst) { - SCM_VALIDATE_PROC (SCM_ARG1, pred); - - for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) - if (scm_is_false (scm_call_1 (pred, SCM_CAR (lst)))) - goto done; - - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); - done: - return lst; + CACHE_VAR (drop_while, "drop-while"); + return scm_call_2 (drop_while, pred, lst); } -#undef FUNC_NAME - SCM scm_srfi1_eighth (SCM lst) @@ -966,55 +933,12 @@ scm_srfi1_list_tabulate (SCM n, SCM proc) return scm_call_2 (list_tabulate, n, proc); } -SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1, - (SCM equal, SCM lst, SCM rest), - "Add to @var{list} any of the given @var{elem}s not already in\n" - "the list. @var{elem}s are @code{cons}ed onto the start of\n" - "@var{list} (so the return shares a common tail with\n" - "@var{list}), but the order they're added is unspecified.\n" - "\n" - "The given @var{=} procedure is used for comparing elements,\n" - "called as @code{(@var{=} listelem elem)}, ie.@: the second\n" - "argument is one of the given @var{elem} parameters.\n" - "\n" - "@example\n" - "(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n" - "@end example") -#define FUNC_NAME s_scm_srfi1_lset_adjoin +SCM +scm_srfi1_lset_adjoin (SCM equal, SCM lst, SCM rest) { - SCM l, elem; - - SCM_VALIDATE_PROC (SCM_ARG1, equal); - SCM_VALIDATE_REST_ARGUMENT (rest); - - /* It's not clear if duplicates among the `rest' elements are meant to be - cast out. The spec says `=' is called as (= list-elem rest-elem), - suggesting perhaps not, but the reference implementation shows the - "list" at each stage as including those "rest" elements already added. - The latter corresponds to what's described for lset-union, so that's - what's done here. */ - - for ( ; scm_is_pair (rest); rest = SCM_CDR (rest)) - { - elem = SCM_CAR (rest); - - for (l = lst; scm_is_pair (l); l = SCM_CDR (l)) - if (scm_is_true (scm_call_2 (equal, SCM_CAR (l), elem))) - goto next_elem; /* elem already in lst, don't add */ - - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l), lst, SCM_ARG2, FUNC_NAME, "list"); - - /* elem is not equal to anything already in lst, add it */ - lst = scm_cons (elem, lst); - - next_elem: - ; - } - - return lst; + CACHE_VAR (lset_adjoin, "lset-adjoin"); + return scm_apply_1 (lset_adjoin, lst, rest); } -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1, (SCM equal, SCM lst, SCM rest), @@ -1454,126 +1378,19 @@ SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_reduce, "reduce", 3, 0, 0, - (SCM proc, SCM def, SCM lst), - "@code{reduce} is a variant of @code{fold}, where the first call\n" - "to @var{proc} is on two elements from @var{lst}, rather than\n" - "one element and a given initial value.\n" - "\n" - "If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n" - "the only use for @var{def}). If @var{lst} has just one element\n" - "then that's the return value. Otherwise @var{proc} is called\n" - "on the elements of @var{lst}.\n" - "\n" - "Each @var{proc} call is @code{(@var{proc} @var{elem}\n" - "@var{previous})}, where @var{elem} is from @var{lst} (the\n" - "second and subsequent elements of @var{lst}), and\n" - "@var{previous} is the return from the previous call to\n" - "@var{proc}. The first element of @var{lst} is the\n" - "@var{previous} for the first call to @var{proc}.\n" - "\n" - "For example, the following adds a list of numbers, the calls\n" - "made to @code{+} are shown. (Of course @code{+} accepts\n" - "multiple arguments and can add a list directly, with\n" - "@code{apply}.)\n" - "\n" - "@example\n" - "(reduce + 0 '(5 6 7)) @result{} 18\n" - "\n" - "(+ 6 5) @result{} 11\n" - "(+ 7 11) @result{} 18\n" - "@end example\n" - "\n" - "@code{reduce} can be used instead of @code{fold} where the\n" - "@var{init} value is an ``identity'', meaning a value which\n" - "under @var{proc} doesn't change the result, in this case 0 is\n" - "an identity since @code{(+ 5 0)} is just 5. @code{reduce}\n" - "avoids that unnecessary call.") -#define FUNC_NAME s_scm_srfi1_reduce +SCM +scm_srfi1_reduce (SCM proc, SCM def, SCM lst) { - SCM ret; - SCM_VALIDATE_PROC (SCM_ARG1, proc); - ret = def; /* if lst is empty */ - if (scm_is_pair (lst)) - { - ret = SCM_CAR (lst); /* if lst has one element */ - - for (lst = SCM_CDR (lst); scm_is_pair (lst); lst = SCM_CDR (lst)) - ret = scm_call_2 (proc, SCM_CAR (lst), ret); - } - - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG3, FUNC_NAME, "list"); - return ret; + CACHE_VAR (reduce, "reduce"); + return scm_call_3 (reduce, proc, def, lst); } -#undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_reduce_right, "reduce-right", 3, 0, 0, - (SCM proc, SCM def, SCM lst), - "@code{reduce-right} is a variant of @code{fold-right}, where\n" - "the first call to @var{proc} is on two elements from @var{lst},\n" - "rather than one element and a given initial value.\n" - "\n" - "If @var{lst} is empty, @code{reduce-right} returns @var{def}\n" - "(this is the only use for @var{def}). If @var{lst} has just\n" - "one element then that's the return value. Otherwise @var{proc}\n" - "is called on the elements of @var{lst}.\n" - "\n" - "Each @var{proc} call is @code{(@var{proc} @var{elem}\n" - "@var{previous})}, where @var{elem} is from @var{lst} (the\n" - "second last and then working back to the first element of\n" - "@var{lst}), and @var{previous} is the return from the previous\n" - "call to @var{proc}. The last element of @var{lst} is the\n" - "@var{previous} for the first call to @var{proc}.\n" - "\n" - "For example, the following adds a list of numbers, the calls\n" - "made to @code{+} are shown. (Of course @code{+} accepts\n" - "multiple arguments and can add a list directly, with\n" - "@code{apply}.)\n" - "\n" - "@example\n" - "(reduce-right + 0 '(5 6 7)) @result{} 18\n" - "\n" - "(+ 6 7) @result{} 13\n" - "(+ 5 13) @result{} 18\n" - "@end example\n" - "\n" - "@code{reduce-right} can be used instead of @code{fold-right}\n" - "where the @var{init} value is an ``identity'', meaning a value\n" - "which under @var{proc} doesn't change the result, in this case\n" - "0 is an identity since @code{(+ 7 0)} is just 5.\n" - "@code{reduce-right} avoids that unnecessary call.\n" - "\n" - "@code{reduce} should be preferred over @code{reduce-right} if\n" - "the order of processing doesn't matter, or can be arranged\n" - "either way, since @code{reduce} is a little more efficient.") -#define FUNC_NAME s_scm_srfi1_reduce_right +SCM +scm_srfi1_reduce_right (SCM proc, SCM def, SCM lst) { - /* To work backwards across a list requires either repeatedly traversing - to get each previous element, or using some memory for a reversed or - random-access form. Repeated traversal might not be too terrible, but - is of course quadratic complexity and hence to be avoided in case LST - is long. A vector is preferred over a reversed list since it's more - compact and is less work for the gc to collect. */ - - SCM vec, ret; - ssize_t len, i; - SCM_VALIDATE_PROC (SCM_ARG1, proc); - if (SCM_NULL_OR_NIL_P (lst)) - return def; - - vec = scm_vector (lst); - len = SCM_SIMPLE_VECTOR_LENGTH (vec); - - ret = SCM_SIMPLE_VECTOR_REF (vec, len-1); - for (i = len-2; i >= 0; i--) - ret = scm_call_2 (proc, SCM_SIMPLE_VECTOR_REF (vec, i), ret); - - return ret; + CACHE_VAR (reduce_right, "reduce-right"); + return scm_call_3 (reduce_right, proc, def, lst); } -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0, (SCM pred, SCM list), @@ -1650,67 +1467,19 @@ scm_srfi1_sixth (SCM lst) return scm_call_1 (sixth, lst); } - -SCM_DEFINE (scm_srfi1_span, "span", 2, 0, 0, - (SCM pred, SCM lst), - "Return two values, the longest initial prefix of @var{lst}\n" - "whose elements all satisfy the predicate @var{pred}, and the\n" - "remainder of @var{lst}.") -#define FUNC_NAME s_scm_srfi1_span +SCM +scm_srfi1_span (SCM pred, SCM lst) { - SCM ret, *p; - - 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_false (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)); + CACHE_VAR (span, "span"); + return scm_call_2 (span, pred, lst); } -#undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_span_x, "span!", 2, 0, 0, - (SCM pred, SCM lst), - "Return two values, the longest initial prefix of @var{lst}\n" - "whose elements all satisfy 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_span_x +SCM +scm_srfi1_span_x (SCM pred, SCM lst) { - SCM upto, *p; - - 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_false (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)); + CACHE_VAR (span_x, "span!"); + return scm_call_2 (span_x, pred, lst); } -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0, (SCM lst, SCM n), @@ -1762,33 +1531,12 @@ SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_take_x, "take!", 2, 0, 0, - (SCM lst, SCM n), - "Return a list containing the first @var{n} elements of\n" - "@var{lst}.") -#define FUNC_NAME s_scm_srfi1_take_x +SCM +scm_srfi1_take_x (SCM lst, SCM n) { - long nn; - SCM pos; - - nn = scm_to_signed_integer (n, 0, LONG_MAX); - if (nn == 0) - return SCM_EOL; - - pos = scm_list_tail (lst, scm_from_long (nn - 1)); - - /* Must have at least one cell left, mustn't have reached the end of an - n-1 element list. SCM_VALIDATE_CONS here gives the same error as - scm_list_tail does on say an n-2 element list, though perhaps a range - error would make more sense (for both). */ - SCM_VALIDATE_CONS (SCM_ARG1, pos); - - SCM_SETCDR (pos, SCM_EOL); - return lst; + CACHE_VAR (take_x, "take!"); + return scm_call_2 (take_x, lst, n); } -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0, (SCM lst, SCM n), @@ -1808,63 +1556,19 @@ SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_srfi1_take_while, "take-while", 2, 0, 0, - (SCM pred, SCM lst), - "Return a new list which is the longest initial prefix of\n" - "@var{lst} whose elements all satisfy the predicate @var{pred}.") -#define FUNC_NAME s_scm_srfi1_take_while +SCM +scm_srfi1_take_while (SCM pred, SCM lst) { - SCM ret, *p; - - 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_false (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 ret; + CACHE_VAR (take_while, "take-while"); + return scm_call_2 (take_while, pred, lst); } -#undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_take_while_x, "take-while!", 2, 0, 0, - (SCM pred, SCM lst), - "Return the longest initial prefix of @var{lst} whose elements\n" - "all satisfy the predicate @var{pred}. @var{lst} may be\n" - "modified to form the return.") -#define FUNC_NAME s_scm_srfi1_take_while_x +SCM +scm_srfi1_take_while_x (SCM pred, SCM lst) { - SCM upto, *p; - - 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_false (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 lst; + CACHE_VAR (take_while_x, "take-while!"); + return scm_call_2 (take_while_x, pred, lst); } -#undef FUNC_NAME SCM scm_srfi1_tenth (SCM lst)