/* srfi-1.c --- SRFI-1 procedures for Guile
*
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003 Free Software
- * Foundation, Inc.
- *
+ * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008
+ * Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <libguile.h>
#include <libguile/lang.h>
return scm_equal_p (arg1, arg2);
}
+/* list_copy_part() copies the first COUNT cells of LST, puts the result at
+ *dst, and returns the SCM_CDRLOC of the last cell in that new list.
+
+ This function is designed to be careful about LST possibly having changed
+ in between the caller deciding what to copy, and the copy actually being
+ done here. The COUNT ensures we terminate if LST has become circular,
+ SCM_VALIDATE_CONS guards against a cdr in the list changed to some
+ non-pair object. */
+
+#include <stdio.h>
+static SCM *
+list_copy_part (SCM lst, int count, SCM *dst)
+#define FUNC_NAME "list_copy_part"
+{
+ SCM c;
+ for ( ; count > 0; count--)
+ {
+ SCM_VALIDATE_CONS (SCM_ARGn, lst);
+ c = scm_cons (SCM_CAR (lst), SCM_EOL);
+ *dst = c;
+ dst = SCM_CDRLOC (c);
+ lst = SCM_CDR (lst);
+ }
+ return dst;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_srfi1_alist_copy, "alist-copy", 1, 0, 0,
(SCM alist),
#undef FUNC_NAME
+
+SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0,
+ (SCM revhead, SCM tail),
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
+ "result. This is equivalent to @code{(append (reverse\n"
+ "@var{rev-head}) @var{tail})}, but its implementation is more\n"
+ "efficient.\n"
+ "\n"
+ "@example\n"
+ "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_append_reverse
+{
+ while (scm_is_pair (revhead))
+ {
+ /* copy first element of revhead onto front of tail */
+ tail = scm_cons (SCM_CAR (revhead), tail);
+ revhead = SCM_CDR (revhead);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
+ "list");
+ return tail;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
+ (SCM revhead, SCM tail),
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
+ "result. This is equivalent to @code{(append! (reverse!\n"
+ "@var{rev-head}) @var{tail})}, but its implementation is more\n"
+ "efficient.\n"
+ "\n"
+ "@example\n"
+ "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
+ "@end example\n"
+ "\n"
+ "@var{rev-head} may be modified in order to produce the result.")
+#define FUNC_NAME s_scm_srfi1_append_reverse_x
+{
+ SCM newtail;
+
+ while (scm_is_pair (revhead))
+ {
+ /* take the first cons cell from revhead */
+ newtail = revhead;
+ revhead = SCM_CDR (revhead);
+
+ /* make it the new start of tail, appending the previous */
+ SCM_SETCDR (newtail, tail);
+ tail = newtail;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
+ "list");
+ return tail;
+}
+#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"
{
scm_t_trampoline_2 equal_p;
SCM ret, *p, keeplst;
+ int count;
if (SCM_UNBNDP (pred))
return scm_delete (x, lst);
elements are considered.
Elements to be retained are not immediately copied, instead keeplst is
- the last pair in lst which is to be retained but not yet copied. When
- there's no more deletions, *p can be set to keeplst to share the
- remainder of the original lst. (The entire original lst if there's no
- deletions at all.) */
+ the last pair in lst which is to be retained but not yet copied, count
+ is how many from there are wanted. When there's no more deletions, *p
+ can be set to keeplst to share the remainder of the original lst. (The
+ entire original lst if there's no deletions at all.) */
keeplst = lst;
- ret = SCM_EOL;
+ count = 0;
p = &ret;
for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
{
- /* delete this element, so copy from keeplst (inclusive) to lst
- (exclusive) onto ret */
- while (! scm_is_eq (keeplst, lst))
- {
- SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
- *p = c;
- p = SCM_CDRLOC (c);
- keeplst = SCM_CDR (keeplst);
- }
-
+ /* delete this element, so copy those at keeplst */
+ p = list_copy_part (keeplst, count, p);
keeplst = SCM_CDR (lst);
+ count = 0;
+ }
+ else
+ {
+ /* keep this element */
+ count++;
}
}
{
scm_t_trampoline_2 equal_p;
SCM ret, *p, keeplst, item, l;
+ int count, i;
/* ret is the new list constructed. p is where to append, initially &ret
then SCM_CDRLOC of the last pair. lst is advanced as each element is
deletions.) */
/* skip to end if an empty list (or something invalid) */
- ret = lst;
- if (scm_is_pair (lst))
+ ret = SCM_EOL;
+
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
{
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- equal_p = scm_trampoline_2 (pred);
- SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
- }
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
+ }
+
+ keeplst = lst;
+ count = 0;
+ p = &ret;
- keeplst = lst;
- p = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ item = SCM_CAR (lst);
- /* loop over lst elements starting from second */
- for (;;)
+ /* look for item in "ret" list */
+ for (l = ret; scm_is_pair (l); l = SCM_CDR (l))
{
- lst = SCM_CDR (lst);
- if (! scm_is_pair (lst))
- break;
- item = SCM_CAR (lst);
-
- /* loop searching ret upto lst */
- for (l = ret; ! scm_is_eq (l, lst); l = SCM_CDR (l))
+ if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
{
- if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
- {
- /* duplicate, don't want this element, so copy keeplst
- (inclusive) to lst (exclusive) onto ret */
- while (! scm_is_eq (keeplst, lst))
- {
- SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
- *p = c;
- p = SCM_CDRLOC (c);
- keeplst = SCM_CDR (keeplst);
- }
-
- keeplst = SCM_CDR (lst); /* elem after the one deleted */
- *p = keeplst;
- break;
- }
+ /* "item" is a duplicate, so copy keeplst onto ret */
+ duplicate:
+ p = list_copy_part (keeplst, count, p);
+
+ keeplst = SCM_CDR (lst); /* elem after the one deleted */
+ count = 0;
+ goto next_elem;
}
}
- }
- /* demand that lst was a proper list */
+ /* look for item in "keeplst" list
+ be careful traversing, in case nasty code changed the cdrs */
+ for (i = 0, l = keeplst;
+ i < count && scm_is_pair (l);
+ i++, l = SCM_CDR (l))
+ if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
+ goto duplicate;
+
+ /* keep this element */
+ count++;
+
+ next_elem:
+ ;
+ }
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
+ /* share tail of keeplst items */
+ *p = keeplst;
+
return ret;
}
#undef FUNC_NAME
#undef FUNC_NAME
+SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
+ (SCM equal, SCM lst, SCM rest),
+ "Return @var{lst} with any elements in the lists in @var{rest}\n"
+ "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
+ "just that list is returned.\n"
+ "\n"
+ "The given @var{equal} procedure is used for comparing elements,\n"
+ "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
+ "is from @var{lst} and the second from one of the subsequent\n"
+ "lists. But exactly which calls are made and in what order is\n"
+ "unspecified.\n"
+ "\n"
+ "@example\n"
+ "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
+ "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
+ "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
+ "@end example\n"
+ "\n"
+ "@code{lset-difference!} may modify @var{lst} to form its\n"
+ "result.")
+#define FUNC_NAME s_scm_srfi1_lset_difference_x
+{
+ scm_t_trampoline_2 equal_tramp = scm_trampoline_2 (equal);
+ SCM ret, *pos, elem, r, b;
+ int argnum;
+
+ SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ ret = SCM_EOL;
+ pos = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ elem = SCM_CAR (lst);
+
+ for (r = rest, argnum = SCM_ARG3;
+ scm_is_pair (r);
+ r = SCM_CDR (r), argnum++)
+ {
+ for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
+ if (scm_is_true (equal_tramp (equal, elem, SCM_CAR (b))))
+ goto next_elem; /* equal to elem, so drop that elem */
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
+ }
+
+ /* elem not equal to anything in later lists, so keep it */
+ *pos = lst;
+ pos = SCM_CDRLOC (lst);
+
+ next_elem:
+ ;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ *pos = SCM_EOL;
+ return ret;
+}
+#undef FUNC_NAME
+
+
/* Typechecking for multi-argument MAP and FOR-EACH.
Verify that each element of the vector ARGV, except for the first,
SCM tmp = SCM_CAR (ls);
SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
"association list");
- if (scm_is_true (equal_p (pred, SCM_CAR (tmp), key)))
+ if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
return tmp;
}
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
/* In this implementation, the output lists don't share memory with
list, because it's probably not worth the effort. */
scm_t_trampoline_1 call = scm_trampoline_1(pred);
+ SCM orig_list = list;
SCM kept = scm_cons(SCM_EOL, SCM_EOL);
SCM kept_tail = kept;
SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
SCM_ASSERT(call, pred, 2, FUNC_NAME);
for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
- SCM elt = SCM_CAR(list);
- SCM new_tail = scm_cons(SCM_CAR(list), SCM_EOL);
+ SCM elt, new_tail;
+
+ /* Make sure LIST is not a dotted list. */
+ SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
+
+ elt = SCM_CAR (list);
+ new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
+
if (scm_is_true (call (pred, elt))) {
SCM_SETCDR(kept_tail, new_tail);
kept_tail = new_tail;
HCoop / bpt / guile.git / blobdiff