mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
(car+cdr, fold, last, list-index,
list-tabulate, not-pair, xcons): Rewrite in C.
This commit is contained in:
Kevin Ryde
parent
6017642112
commit
e556f8c3c6
3 changed files with 297 additions and 45 deletions
289
srfi/srfi-1.c
289
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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue