[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-302-ga
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-302-gac37b82 |
|
Date: |
Wed, 01 Sep 2010 22:05:08 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ac37b82d5bc0bc7fc5777b069a7f198622b6cbb7
The branch, master has been updated
via ac37b82d5bc0bc7fc5777b069a7f198622b6cbb7 (commit)
via dcde43869ae42996fee7071790789322e214d78e (commit)
from 5335850dbf9f11e9bbef0c8f88f12b684885db19 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ac37b82d5bc0bc7fc5777b069a7f198622b6cbb7
Author: Ludovic Courtès <address@hidden>
Date: Thu Sep 2 00:04:39 2010 +0200
Fix typos.
* module/system/repl/repl.scm (run-repl): Fix variable name: `k', not
`key'.
* module/texinfo/docbook.scm: Use `(srfi srfi-1)' for `fold'.
commit dcde43869ae42996fee7071790789322e214d78e
Author: Ludovic Courtès <address@hidden>
Date: Thu Sep 2 00:03:07 2010 +0200
SRFI-1: Rewrite `drop-right!', `drop-while', `reduce', etc. in Scheme.
This partially reverts commit e9508fbb7df0b1ead007637f16d80cf831776307
(May 3 2005).
* module/srfi/srfi-1.scm (take!, drop-right!, reduce, reduce-right,
take-while, take-while!, drop-while, span, span!, lset-adjoin): New
procedures.
* srfi/srfi-1.c (scm_srfi1_drop_right_x, scm_srfi1_drop_while,
scm_srfi1_lset_adjoin, scm_srfi1_reduce, scm_srfi1_reduce_right,
scm_srfi1_span, scm_srfi1_span_x, scm_srfi1_take_x,
scm_srfi1_take_while, scm_srfi1_take_while_x): Rewrite as
proxies to the corresponding Scheme procedures.
* benchmark-suite/benchmarks/srfi-1.bm ("drop-while"): New benchmark
prefix.
-----------------------------------------------------------------------
Summary of changes:
benchmark-suite/benchmarks/srfi-1.bm | 9 +
module/srfi/srfi-1.scm | 127 ++++++++++++
module/system/repl/repl.scm | 2 +-
module/texinfo/docbook.scm | 15 +-
srfi/srfi-1.c | 376 ++++------------------------------
5 files changed, 185 insertions(+), 344 deletions(-)
diff --git a/benchmark-suite/benchmarks/srfi-1.bm
b/benchmark-suite/benchmarks/srfi-1.bm
index e07d3b9..835608d 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 8527293..1e27d6f 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/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 9e364dd..8711e1d 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -133,7 +133,7 @@
((,subr ,msg ,args . ,rest)
(display-error #f (current-output-port) subr msg
args rest))
(else
- (format #t "ERROR: Throw to key `~a' with args
`~s'.\n" key args)))
+ (format #t "ERROR: Throw to key `~a' with args
`~s'.\n" k args)))
(force-output))))))
((eof-object? exp)
(newline)
diff --git a/module/texinfo/docbook.scm b/module/texinfo/docbook.scm
index f760e5b..7277926 100644
--- a/module/texinfo/docbook.scm
+++ b/module/texinfo/docbook.scm
@@ -1,6 +1,6 @@
;;;; (texinfo docbook) -- translating sdocbook into stexinfo
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -30,12 +30,13 @@
;;; Code:
(define-module (texinfo docbook)
- :use-module (sxml fold)
- :export (*sdocbook->stexi-rules*
- *sdocbook-block-commands*
- sdocbook-flatten
- filter-empty-elements
- replace-titles))
+ #:use-module (sxml fold)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export (*sdocbook->stexi-rules*
+ *sdocbook-block-commands*
+ sdocbook-flatten
+ filter-empty-elements
+ replace-titles))
(define (identity . args)
args)
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 02c580d..b81c905 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)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-11-302-gac37b82,
Ludovic Courtès <=