summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKevin Ryde <user42@zip.com.au>2005-05-06 23:59:35 +0000
committerKevin Ryde <user42@zip.com.au>2005-05-06 23:59:35 +0000
commite556f8c3c6b74ee6596e8dcbe829109d7745da2c (patch)
tree2bc3871e187dfd5a52016deb21b868081236cd95
parent6017642112daa7a14145e0c36ff3862e5d9f8d06 (diff)
downloadguile-e556f8c3c6b74ee6596e8dcbe829109d7745da2c.tar.gz
(car+cdr, fold, last, list-index,
list-tabulate, not-pair, xcons): Rewrite in C.
-rw-r--r--srfi/srfi-1.c289
-rw-r--r--srfi/srfi-1.h7
-rw-r--r--srfi/srfi-1.scm46
3 files changed, 297 insertions, 45 deletions
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index a746732a4..aa56a62db 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -167,6 +167,17 @@ SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
#undef FUNC_NAME
+SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0,
+ (SCM pair),
+ "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
+#define FUNC_NAME s_scm_srfi1_car_plus_cdr
+{
+ SCM_VALIDATE_CONS (SCM_ARG1, pair);
+ return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair)));
+}
+#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"
@@ -848,6 +859,132 @@ SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
#undef FUNC_NAME
+SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1,
+ (SCM proc, SCM init, SCM list1, SCM rest),
+ "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
+ "@var{lstN} to build a result, and return that result.\n"
+ "\n"
+ "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
+ "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
+ "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
+ "@var{previous} is the return from the previous call to\n"
+ "@var{proc}, or the given @var{init} for the first call. If any\n"
+ "list is empty, just @var{init} is returned.\n"
+ "\n"
+ "@code{fold} works through the list elements from first to last.\n"
+ "The following shows a list reversal and the calls it makes,\n"
+ "\n"
+ "@example\n"
+ "(fold cons '() '(1 2 3))\n"
+ "\n"
+ "(cons 1 '())\n"
+ "(cons 2 '(1))\n"
+ "(cons 3 '(2 1)\n"
+ "@result{} (3 2 1)\n"
+ "@end example\n"
+ "\n"
+ "If @var{lst1} through @var{lstN} have different lengths,\n"
+ "@code{fold} stops when the end of the shortest is reached.\n"
+ "Ie.@: elements past the length of the shortest are ignored in\n"
+ "the other @var{lst}s. At least one @var{lst} must be\n"
+ "non-circular.\n"
+ "\n"
+ "The way @code{fold} builds a result from iterating is quite\n"
+ "general, it can do more than other iterations like say\n"
+ "@code{map} or @code{filter}. The following for example removes\n"
+ "adjacent duplicate elements from a list,\n"
+ "\n"
+ "@example\n"
+ "(define (delete-adjacent-duplicates lst)\n"
+ " (fold-right (lambda (elem ret)\n"
+ " (if (equal? elem (first ret))\n"
+ " ret\n"
+ " (cons elem ret)))\n"
+ " (list (last lst))\n"
+ " lst))\n"
+ "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
+ "@result{} (1 2 3 4 5)\n"
+ "@end example\n"
+ "\n"
+ "Clearly the same sort of thing can be done with a\n"
+ "@code{for-each} and a variable in which to build the result,\n"
+ "but a self-contained @var{proc} can be re-used in multiple\n"
+ "contexts, where a @code{for-each} would have to be written out\n"
+ "each time.")
+#define FUNC_NAME s_scm_srfi1_fold
+{
+ SCM lst;
+ int argnum;
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+ init = proc_tramp (proc, SCM_CAR (list1), init);
+
+ /* check below that list1 is a proper list, and done */
+ lst = list1;
+ argnum = 2;
+ }
+ else
+ {
+ /* two or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to proc, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED);
+
+ for (;;)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto check_lst_and_done;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+ SCM_SETCAR (a, init);
+
+ init = scm_apply (proc, args, SCM_EOL);
+ }
+ }
+
+ check_lst_and_done:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return init;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0,
+ (SCM lst),
+ "Like @code{cons}, but with interchanged arguments. Useful\n"
+ "mostly when passed to higher-order procedures.")
+#define FUNC_NAME s_scm_srfi1_last
+{
+ SCM pair = scm_last_pair (lst);
+ /* scm_last_pair returns SCM_EOL for an empty list */
+ SCM_VALIDATE_CONS (SCM_ARG1, pair);
+ return SCM_CAR (pair);
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
(SCM lst),
"Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
@@ -860,6 +997,109 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
#undef FUNC_NAME
+SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1,
+ (SCM pred, SCM list1, SCM rest),
+ "Return the index of the first set of elements, one from each of\n"
+ "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n"
+ "\n"
+ "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
+ "elemN)}. Searching stops when the end of the shortest\n"
+ "@var{lst} is reached. The return index starts from 0 for the\n"
+ "first set of elements. If no set of elements pass then the\n"
+ "return is @code{#f}.\n"
+ "\n"
+ "@example\n"
+ "(list-index odd? '(2 4 6 9)) @result{} 3\n"
+ "(list-index = '(1 2 3) '(3 1 2)) @result{} #f\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_list_index
+{
+ long n = 0;
+ SCM lst;
+ int argnum;
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (list1))))
+ return SCM_I_MAKINUM (n);
+
+ /* not found, check below that list1 is a proper list */
+ end_list1:
+ lst = list1;
+ argnum = 2;
+ }
+ else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
+ {
+ /* two lists */
+ SCM list2 = SCM_CAR (rest);
+ scm_t_trampoline_2 pred_tramp = scm_trampoline_2 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; ; n++)
+ {
+ if (! scm_is_pair (list1))
+ goto end_list1;
+ if (! scm_is_pair (list2))
+ {
+ lst = list2;
+ argnum = 3;
+ break;
+ }
+ if (scm_is_true (pred_tramp (pred,
+ SCM_CAR (list1), SCM_CAR (list2))))
+ return SCM_I_MAKINUM (n);
+
+ list1 = SCM_CDR (list1);
+ list2 = SCM_CDR (list2);
+ }
+ }
+ else
+ {
+ /* three or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to pred, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
+
+ for ( ; ; n++)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto not_found_check_lst;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+
+ if (scm_is_true (scm_apply (pred, args, SCM_EOL)))
+ return SCM_I_MAKINUM (n);
+ }
+ }
+
+ not_found_check_lst:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
/* This routine differs from the core list-copy in allowing improper lists.
Maybe the core could allow them similarly. */
@@ -893,6 +1133,29 @@ SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
#undef FUNC_NAME
+SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0,
+ (SCM n, SCM proc),
+ "Return an @var{n}-element list, where each list element is\n"
+ "produced by applying the procedure @var{init-proc} to the\n"
+ "corresponding list index. The order in which @var{init-proc}\n"
+ "is applied to the indices is not specified.")
+#define FUNC_NAME s_scm_srfi1_list_tabulate
+{
+ long i, nn;
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+ SCM ret = SCM_EOL;
+
+ SCM_VALIDATE_INUM_MIN_COPY (SCM_ARG1, n, 0, nn);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG2, FUNC_NAME);
+
+ for (i = nn-1; i >= 0; i--)
+ ret = scm_cons (proc_tramp (proc, SCM_I_MAKINUM (i)), ret);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
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"
@@ -1219,6 +1482,21 @@ SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
#undef FUNC_NAME
+SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
+ "otherwise.\n"
+ "\n"
+ "This is shorthand notation @code{(not (pair? @var{obj}))} and\n"
+ "is supposed to be used for end-of-list checking in contexts\n"
+ "where dotted lists are allowed.")
+#define FUNC_NAME s_scm_srfi1_not_pair_p
+{
+ return scm_from_bool (! scm_is_pair (obj));
+}
+#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"
@@ -1760,6 +2038,17 @@ SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
#undef FUNC_NAME
+SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0,
+ (SCM d, SCM a),
+ "Like @code{cons}, but with interchanged arguments. Useful\n"
+ "mostly when passed to higher-order procedures.")
+#define FUNC_NAME s_scm_srfi1_xcons
+{
+ return scm_cons (a, d);
+}
+#undef FUNC_NAME
+
+
void
scm_init_srfi_1 (void)
{
diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h
index 3f8f81e8b..0a20c6b16 100644
--- a/srfi/srfi-1.h
+++ b/srfi/srfi-1.h
@@ -35,6 +35,7 @@
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_car_plus_cdr (SCM pair);
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);
@@ -50,14 +51,19 @@ SCM_SRFI1_API SCM scm_srfi1_fifth (SCM lst);
SCM_SRFI1_API SCM scm_srfi1_filter_map (SCM proc, SCM list1, SCM rest);
SCM_SRFI1_API SCM scm_srfi1_find (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_find_tail (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_last (SCM lst);
SCM_SRFI1_API SCM scm_srfi1_length_plus (SCM lst);
SCM_SRFI1_API SCM scm_srfi1_lset_adjoin (SCM equal, SCM lst, SCM rest);
SCM_SRFI1_API SCM scm_srfi1_list_copy (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_list_index (SCM pred, SCM list1, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_list_tabulate (SCM n, SCM proc);
SCM_SRFI1_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
SCM_SRFI1_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
SCM_SRFI1_API SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred);
SCM_SRFI1_API SCM scm_srfi1_ninth (SCM lst);
SCM_SRFI1_API SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_not_pair_p (SCM obj);
SCM_SRFI1_API SCM scm_srfi1_partition (SCM pred, SCM list);
SCM_SRFI1_API SCM scm_srfi1_partition_x (SCM pred, SCM list);
SCM_SRFI1_API SCM scm_srfi1_reduce (SCM proc, SCM def, SCM lst);
@@ -75,6 +81,7 @@ SCM_SRFI1_API SCM scm_srfi1_take_right (SCM lst, SCM n);
SCM_SRFI1_API SCM scm_srfi1_take_while (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_take_while_x (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_tenth (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_xcons (SCM d, SCM a);
SCM_SRFI1_API void scm_init_srfi_1 (void);
diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index 36da13b75..7fd1b67c2 100644
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -225,9 +225,6 @@
;;; Constructors
-(define (xcons d a)
- (cons a d))
-
;; internal helper, similar to (scsh utilities) check-arg.
(define (check-arg-type pred arg caller)
(if (pred arg)
@@ -238,12 +235,7 @@
;; the srfi spec doesn't seem to forbid inexact integers.
(define (non-negative-integer? x) (and (integer? x) (>= x 0)))
-(define (list-tabulate n init-proc)
- (check-arg-type non-negative-integer? n "list-tabulate")
- (let lp ((n n) (acc '()))
- (if (<= n 0)
- acc
- (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
+
(define (circular-list elt1 . elts)
(set! elts (cons elt1 elts))
@@ -304,9 +296,6 @@
(else
(error "not a proper list in null-list?"))))
-(define (not-pair? x)
- (not (pair? x)))
-
(define (list= elt= . rest)
(define (lists-equal a b)
(let lp ((a a) (b b))
@@ -330,14 +319,9 @@
(define third caddr)
(define fourth cadddr)
-(define (car+cdr x) (values (car x) (cdr x)))
-
(define take list-head)
(define drop list-tail)
-(define (last pair)
- (car (last-pair pair)))
-
;;; Miscelleneous: length, append, concatenate, reverse, zip & count
(define (append-reverse rev-head tail)
@@ -370,19 +354,6 @@
;;; Fold, unfold & map
-(define (fold kons knil list1 . rest)
- (if (null? rest)
- (let f ((knil knil) (list1 list1))
- (if (null? list1)
- knil
- (f (kons (car list1) knil) (cdr list1))))
- (let f ((knil knil) (lists (cons list1 rest)))
- (if (any null? lists)
- knil
- (let ((cars (map1 car lists))
- (cdrs (map1 cdr lists)))
- (f (apply kons (append! cars (list knil))) cdrs))))))
-
(define (fold-right kons knil clist1 . rest)
(if (null? rest)
(let f ((list1 clist1))
@@ -516,21 +487,6 @@
(else
(and (pred (car ls)) (lp (cdr ls)))))))
-(define (list-index pred clist1 . rest)
- (if (null? rest)
- (let lp ((l clist1) (i 0))
- (if (null? l)
- #f
- (if (pred (car l))
- i
- (lp (cdr l) (+ i 1)))))
- (let lp ((lists (cons clist1 rest)) (i 0))
- (cond ((any1 null? lists)
- #f)
- ((apply pred (map1 car lists)) i)
- (else
- (lp (map1 cdr lists) (+ i 1)))))))
-
;;; Association lists
(define alist-cons acons)