-/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004
+ * Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
#include "libguile/_scm.h"
#include "libguile/eq.h"
+#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/list.h"
+#include "libguile/eval.h"
-#ifdef __STDC__
#include <stdarg.h>
-#define var_start(x, y) va_start(x, y)
-#else
-#include <varargs.h>
-#define var_start(x, y) va_start(x)
-#endif
\f
/* creating lists */
+#define SCM_I_CONS(cell, x, y) \
+do { \
+ cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y); \
+} while (0)
+
+SCM
+scm_list_1 (SCM e1)
+{
+ SCM c1;
+ SCM_I_CONS (c1, e1, SCM_EOL);
+ return c1;
+}
+
+SCM
+scm_list_2 (SCM e1, SCM e2)
+{
+ SCM c1, c2;
+ SCM_I_CONS (c2, e2, SCM_EOL);
+ SCM_I_CONS (c1, e1, c2);
+ return c1;
+}
+
+SCM
+scm_list_3 (SCM e1, SCM e2, SCM e3)
+{
+ SCM c1, c2, c3;
+ SCM_I_CONS (c3, e3, SCM_EOL);
+ SCM_I_CONS (c2, e2, c3);
+ SCM_I_CONS (c1, e1, c2);
+ return c1;
+}
+
SCM
-scm_listify (SCM elt, ...)
+scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4)
+{
+ return scm_cons2 (e1, e2, scm_list_2 (e3, e4));
+}
+
+SCM
+scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5)
+{
+ return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5));
+}
+
+SCM
+scm_list_n (SCM elt, ...)
{
va_list foo;
SCM answer = SCM_EOL;
SCM *pos = &answer;
- var_start (foo, elt);
+ va_start (foo, elt);
while (! SCM_UNBNDP (elt))
{
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (SCM_NIMP (elt))
+ SCM_VALIDATE_CELL(elt, 0);
+#endif
*pos = scm_cons (elt, SCM_EOL);
pos = SCM_CDRLOC (*pos);
elt = va_arg (foo, SCM);
}
+ va_end (foo);
return answer;
}
-SCM_DEFINE (scm_list, "list", 0, 0, 1,
- (SCM objs),
- "Return a list containing @var{objs}, the arguments to\n"
- "@code{list}.")
-#define FUNC_NAME s_scm_list
+SCM_DEFINE (scm_make_list, "make-list", 1, 1, 0,
+ (SCM n, SCM init),
+ "Create a list containing of @var{n} elements, where each\n"
+ "element is initialized to @var{init}. @var{init} defaults to\n"
+ "the empty list @code{()} if not given.")
+#define FUNC_NAME s_scm_make_list
{
- return objs;
-}
-#undef FUNC_NAME
+ unsigned nn = scm_to_uint (n);
+ unsigned i;
+ SCM ret = SCM_EOL;
+ if (SCM_UNBNDP (init))
+ init = SCM_EOL;
-#if (SCM_DEBUG_DEPRECATED == 0)
-
-SCM_REGISTER_PROC (s_list_star, "list*", 1, 0, 1, scm_cons_star);
+ for (i = 0; i < nn; i++)
+ ret = scm_cons (init, ret);
+ return ret;
+}
+#undef FUNC_NAME
-#endif /* SCM_DEBUG_DEPRECATED == 0 */
-SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1,
+SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1,
(SCM arg, SCM rest),
"Like @code{list}, but the last arg provides the tail of the\n"
"constructed list, returning @code{(cons @var{arg1} (cons\n"
"Schemes and in Common LISP.")
#define FUNC_NAME s_scm_cons_star
{
+ SCM ret = SCM_EOL;
+ SCM *p = &ret;
+
SCM_VALIDATE_REST_ARGUMENT (rest);
- if (!SCM_NULLP (rest))
+
+ for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
{
- SCM prev = arg = scm_cons (arg, rest);
- while (SCM_NNULLP (SCM_CDR (rest)))
- {
- prev = rest;
- rest = SCM_CDR (rest);
- }
- SCM_SETCDR (prev, SCM_CAR (rest));
+ *p = scm_cons (arg, SCM_EOL);
+ p = SCM_CDRLOC (*p);
+ arg = SCM_CAR (rest);
}
- return arg;
+
+ *p = arg;
+ return ret;
}
#undef FUNC_NAME
"Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
#define FUNC_NAME s_scm_null_p
{
- return SCM_BOOL (SCM_NULLP (x));
+ return scm_from_bool (SCM_NULL_OR_NIL_P (x));
}
#undef FUNC_NAME
"Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
#define FUNC_NAME s_scm_list_p
{
- return SCM_BOOL (scm_ilength (x) >= 0);
+ return scm_from_bool (scm_ilength (x) >= 0);
}
#undef FUNC_NAME
SCM hare = sx;
do {
- if (SCM_NULLP(hare)) return i;
- if (SCM_NCONSP(hare)) return -1;
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
+ if (!scm_is_pair (hare)) return -1;
hare = SCM_CDR(hare);
i++;
- if (SCM_NULLP(hare)) return i;
- if (SCM_NCONSP(hare)) return -1;
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
+ if (!scm_is_pair (hare)) return -1;
hare = SCM_CDR(hare);
i++;
/* For every two steps the hare takes, the tortoise takes one. */
tortoise = SCM_CDR(tortoise);
}
- while (! SCM_EQ_P (hare, tortoise));
+ while (!scm_is_eq (hare, tortoise));
/* If the tortoise ever catches the hare, then the list must contain
a cycle. */
#define FUNC_NAME s_scm_length
{
long i;
- SCM_VALIDATE_LIST_COPYLEN (1,lst,i);
- return SCM_MAKINUM (i);
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, i);
+ return scm_from_long (i);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_append
{
SCM_VALIDATE_REST_ARGUMENT (args);
- if (SCM_NULLP (args)) {
+ if (scm_is_null (args)) {
return SCM_EOL;
} else {
SCM res = SCM_EOL;
SCM *lloc = &res;
SCM arg = SCM_CAR (args);
+ int argnum = 1;
args = SCM_CDR (args);
- while (!SCM_NULLP (args)) {
- while (SCM_CONSP (arg)) {
+ while (!scm_is_null (args)) {
+ while (scm_is_pair (arg)) {
*lloc = scm_cons (SCM_CAR (arg), SCM_EOL);
lloc = SCM_CDRLOC (*lloc);
arg = SCM_CDR (arg);
}
- SCM_VALIDATE_NULL (SCM_ARGn, arg);
+ SCM_VALIDATE_NULL_OR_NIL (argnum, arg);
arg = SCM_CAR (args);
args = SCM_CDR (args);
+ argnum++;
};
*lloc = arg;
return res;
"A destructive version of @code{append} (@pxref{Pairs and\n"
"Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n"
"of each list's final pair is changed to point to the head of\n"
- "the next list, so no consing is performed. Return a pointer to\n"
+ "the next list, so no consing is performed. Return\n"
"the mutated list.")
#define FUNC_NAME s_scm_append_x
{
+ SCM ret, *loc;
SCM_VALIDATE_REST_ARGUMENT (lists);
- while (1) {
- if (SCM_NULLP (lists)) {
- return SCM_EOL;
- } else {
+
+ if (scm_is_null (lists))
+ return SCM_EOL;
+
+ loc = &ret;
+ for (;;)
+ {
SCM arg = SCM_CAR (lists);
+ *loc = arg;
+
lists = SCM_CDR (lists);
- if (SCM_NULLP (lists)) {
- return arg;
- } else if (!SCM_NULLP (arg)) {
- SCM_VALIDATE_CONS (SCM_ARG1, arg);
- SCM_SETCDR (scm_last_pair (arg), scm_append_x (lists));
- return arg;
- }
+ if (scm_is_null (lists))
+ return ret;
+
+ if (!SCM_NULL_OR_NIL_P (arg))
+ {
+ SCM_VALIDATE_CONS (SCM_ARG1, arg);
+ loc = SCM_CDRLOC (scm_last_pair (arg));
+ }
}
- }
}
#undef FUNC_NAME
SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0,
(SCM lst),
- "Return a pointer to the last pair in @var{lst}, signalling an error if\n"
+ "Return the last pair in @var{lst}, signalling an error if\n"
"@var{lst} is circular.")
#define FUNC_NAME s_scm_last_pair
{
SCM tortoise = lst;
SCM hare = lst;
- if (SCM_NULLP (lst))
- return SCM_EOL;
+ if (SCM_NULL_OR_NIL_P (lst))
+ return lst;
SCM_VALIDATE_CONS (SCM_ARG1, lst);
do {
SCM ahead = SCM_CDR(hare);
- if (SCM_NCONSP(ahead)) return hare;
+ if (!scm_is_pair (ahead)) return hare;
hare = ahead;
ahead = SCM_CDR(hare);
- if (SCM_NCONSP(ahead)) return hare;
+ if (!scm_is_pair (ahead)) return hare;
hare = ahead;
tortoise = SCM_CDR(tortoise);
}
- while (! SCM_EQ_P (hare, tortoise));
- SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst));
+ while (!scm_is_eq (hare, tortoise));
+ SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
}
#undef FUNC_NAME
SCM hare = lst;
do {
- if (SCM_NULLP(hare)) return result;
- SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME);
+ if (SCM_NULL_OR_NIL_P(hare)) return result;
+ SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
result = scm_cons (SCM_CAR (hare), result);
hare = SCM_CDR (hare);
- if (SCM_NULLP(hare)) return result;
- SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME);
+ if (SCM_NULL_OR_NIL_P(hare)) return result;
+ SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
result = scm_cons (SCM_CAR (hare), result);
hare = SCM_CDR (hare);
tortoise = SCM_CDR (tortoise);
}
- while (! SCM_EQ_P (hare, tortoise));
- SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst));
+ while (!scm_is_eq (hare, tortoise));
+ SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
}
#undef FUNC_NAME
(SCM lst, SCM new_tail),
"A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
"The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is\n"
- "modified to point to the previous list element. Return a pointer to the\n"
- "head of the reversed list.\n\n"
+ "modified to point to the previous list element. Return the\n"
+ "reversed list.\n\n"
"Caveat: because the list is modified in place, the tail of the original\n"
"list now becomes its head, and the head of the original list now becomes\n"
"the tail. Therefore, the @var{lst} symbol to which the head of the\n"
else
SCM_VALIDATE_LIST (2, new_tail);
- while (SCM_NNULLP (lst))
+ while (!SCM_NULL_OR_NIL_P (lst))
{
SCM old_tail = SCM_CDR (lst);
SCM_SETCDR (lst, new_tail);
{
SCM lst = list;
unsigned long int i;
- SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
- while (SCM_CONSP (lst)) {
+ i = scm_to_ulong (k);
+ while (scm_is_pair (lst)) {
if (i == 0)
return SCM_CAR (lst);
else {
lst = SCM_CDR (lst);
}
};
- if (SCM_NULLP (lst))
+ if (SCM_NULL_OR_NIL_P (lst))
SCM_OUT_OF_RANGE (2, k);
else
SCM_WRONG_TYPE_ARG (1, list);
#define FUNC_NAME s_scm_list_set_x
{
SCM lst = list;
- unsigned long int i;
- SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
- while (SCM_CONSP (lst)) {
+ unsigned long int i = scm_to_ulong (k);
+ while (scm_is_pair (lst)) {
if (i == 0) {
SCM_SETCAR (lst, val);
return val;
lst = SCM_CDR (lst);
}
};
- if (SCM_NULLP (lst))
+ if (SCM_NULL_OR_NIL_P (lst))
SCM_OUT_OF_RANGE (2, k);
else
SCM_WRONG_TYPE_ARG (1, list);
SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
(SCM lst, SCM k),
- "@deffnx primitive list-cdr-ref lst k\n"
+ "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
"Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
"The first element of the list is considered to be element 0.\n\n"
"@code{list-tail} and @code{list-cdr-ref} are identical. It may help to\n"
"or returning the results of cdring @var{k} times down @var{lst}.")
#define FUNC_NAME s_scm_list_tail
{
- register long i;
- SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
+ size_t i = scm_to_size_t (k);
while (i-- > 0) {
- SCM_VALIDATE_CONS (1,lst);
+ SCM_VALIDATE_CONS (1, lst);
lst = SCM_CDR(lst);
}
return lst;
#define FUNC_NAME s_scm_list_cdr_set_x
{
SCM lst = list;
- unsigned long int i;
- SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
- while (SCM_CONSP (lst)) {
+ size_t i = scm_to_size_t (k);
+ while (scm_is_pair (lst)) {
if (i == 0) {
SCM_SETCDR (lst, val);
return val;
lst = SCM_CDR (lst);
}
};
- if (SCM_NULLP (lst))
+ if (SCM_NULL_OR_NIL_P (lst))
SCM_OUT_OF_RANGE (2, k);
else
SCM_WRONG_TYPE_ARG (1, list);
{
SCM answer;
SCM * pos;
- register long i;
+ size_t i = scm_to_size_t (k);
- SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
answer = SCM_EOL;
pos = &answer;
while (i-- > 0)
{
- SCM_VALIDATE_CONS (1,lst);
+ SCM_VALIDATE_CONS (1, lst);
*pos = scm_cons (SCM_CAR (lst), SCM_EOL);
pos = SCM_CDRLOC (*pos);
lst = SCM_CDR(lst);
#undef FUNC_NAME
+/* Copy a list which is known to be finite. The last pair may or may not have
+ * a '() in its cdr. That is, improper lists are accepted. */
+SCM
+scm_i_finite_list_copy (SCM list)
+{
+ if (!scm_is_pair (list))
+ {
+ return list;
+ }
+ else
+ {
+ SCM tail;
+ const SCM result = tail = scm_list_1 (SCM_CAR (list));
+ list = SCM_CDR (list);
+ while (scm_is_pair (list))
+ {
+ const SCM new_tail = scm_list_1 (SCM_CAR (list));
+ SCM_SETCDR (tail, new_tail);
+ tail = new_tail;
+ list = SCM_CDR (list);
+ }
+ SCM_SETCDR (tail, list);
+
+ return result;
+ }
+}
+
+
SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
(SCM lst),
"Return a (newly-created) copy of @var{lst}.")
fill_here = &newlst;
from_here = lst;
- while (SCM_CONSP (from_here))
+ while (scm_is_pair (from_here))
{
SCM c;
c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
}
#undef FUNC_NAME
-\f
-/* membership tests (memq, memv, etc.) */
-#if SCM_DEBUG_DEPRECATED == 0
+SCM_PROC (s_list, "list", 0, 0, 1, scm_list_copy);
+SCM_SNARF_DOCS (primitive, scm_list_copy, "list", (SCM objs), 0, 0, 1,
+ "Return a list containing @var{objs}, the arguments to\n"
+ "@code{list}.")
-SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{memq}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memq
-{
- for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (SCM_EQ_P (SCM_CAR (lst), x))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{memv}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memv
+/* This used to be the code for "list", but it's wrong when used via apply
+ (it should copy the list). It seems pretty unlikely anyone would have
+ been using this from C code, since it's a no-op, but keep it for strict
+ binary compatibility. */
+SCM
+scm_list (SCM objs)
{
- for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst), x)))
- return lst;
- }
- return lst;
+ return objs;
}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{member}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_member
-{
- for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst), x)))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-#endif /* DEPRECATED */
+\f
+/* membership tests (memq, memv, etc.) */
/* The function scm_c_memq returns the first sublist of list whose car is
* 'eq?' obj, where the sublists of list are the non-empty lists returned by
SCM
scm_c_memq (SCM obj, SCM list)
{
- for (; !SCM_NULLP (list); list = SCM_CDR (list))
+ for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list))
{
- if (SCM_EQ_P (SCM_CAR (list), obj))
+ if (scm_is_eq (SCM_CAR (list), obj))
return list;
}
return SCM_BOOL_F;
#undef FUNC_NAME
-
SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
(SCM x, SCM lst),
"Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
#define FUNC_NAME s_scm_memv
{
SCM_VALIDATE_LIST (2, lst);
- for (; !SCM_NULLP (lst); lst = SCM_CDR (lst))
+ for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
{
- if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst), x)))
+ if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
return lst;
}
return SCM_BOOL_F;
#define FUNC_NAME s_scm_member
{
SCM_VALIDATE_LIST (2, lst);
- for (; !SCM_NULLP (lst); lst = SCM_CDR (lst))
+ for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
{
- if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst), x)))
+ if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
return lst;
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
-
\f
/* deleting elements from a list (delq, etc.) */
SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
(SCM item, SCM lst),
- "@deffnx primitive delv! item lst\n"
- "@deffnx primitive delete! item lst\n"
+ "@deffnx {Scheme Procedure} delv! item lst\n"
+ "@deffnx {Scheme Procedure} delete! item lst\n"
"These procedures are destructive versions of @code{delq}, @code{delv}\n"
- "and @code{delete}: they modify the pointers in the existing @var{lst}\n"
+ "and @code{delete}: they modify the existing @var{lst}\n"
"rather than creating a new list. Caveat evaluator: Like other\n"
"destructive list functions, these functions cannot modify the binding of\n"
"@var{lst}, and so cannot be used to delete the first element of\n"
SCM *prev;
for (prev = &lst, walk = lst;
- SCM_CONSP (walk);
+ scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (SCM_EQ_P (SCM_CAR (walk), item))
+ if (scm_is_eq (SCM_CAR (walk), item))
*prev = SCM_CDR (walk);
else
prev = SCM_CDRLOC (walk);
SCM *prev;
for (prev = &lst, walk = lst;
- SCM_CONSP (walk);
+ scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk), item)))
+ if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
*prev = SCM_CDR (walk);
else
prev = SCM_CDRLOC (walk);
SCM *prev;
for (prev = &lst, walk = lst;
- SCM_CONSP (walk);
+ scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk), item)))
+ if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
*prev = SCM_CDR (walk);
else
prev = SCM_CDRLOC (walk);
SCM *prev;
for (prev = &lst, walk = lst;
- SCM_CONSP (walk);
+ scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (SCM_EQ_P (SCM_CAR (walk), item))
+ if (scm_is_eq (SCM_CAR (walk), item))
{
*prev = SCM_CDR (walk);
break;
SCM *prev;
for (prev = &lst, walk = lst;
- SCM_CONSP (walk);
+ scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk), item)))
+ if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
{
*prev = SCM_CDR (walk);
break;
SCM *prev;
for (prev = &lst, walk = lst;
- SCM_CONSP (walk);
+ scm_is_pair (walk);
walk = SCM_CDR (walk))
{
- if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk), item)))
+ if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
{
*prev = SCM_CDR (walk);
break;
}
#undef FUNC_NAME
+SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
+ "The list is not disordered -- elements that appear in the result list occur\n"
+ "in the same order as they occur in the argument list. The returned list may\n"
+ "share a common tail with the argument list. The dynamic order in which the\n"
+ "various applications of pred are made is not specified.\n\n"
+ "@lisp\n"
+ "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_filter
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (pred);
+ SCM walk;
+ SCM *prev;
+ SCM res = SCM_EOL;
+ SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &res, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_true (call (pred, SCM_CAR (walk))))
+ {
+ *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
+ prev = SCM_CDRLOC (*prev);
+ }
+ }
+
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Linear-update variant of @code{filter}.")
+#define FUNC_NAME s_scm_filter_x
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (pred);
+ SCM walk;
+ SCM *prev;
+ SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &list, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_true (call (pred, SCM_CAR (walk))))
+ prev = SCM_CDRLOC (walk);
+ else
+ *prev = SCM_CDR (walk);
+ }
+
+ return list;
+}
+#undef FUNC_NAME
\f
void
scm_init_list ()
{
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/list.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff