-/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,2000,2001, 2003 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
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
-#include <stdio.h>
-#include "_scm.h"
-#include "eq.h"
+#include "libguile/_scm.h"
+#include "libguile/eq.h"
+#include "libguile/lang.h"
-#include "scm_validate.h"
-#include "list.h"
+#include "libguile/validate.h"
+#include "libguile/list.h"
+#include "libguile/eval.h"
#ifdef __STDC__
#include <stdarg.h>
\f
/* creating lists */
-/* SCM_P won't help us deal with varargs here. */
+#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_listify (SCM elt, ...)
+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_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 *pos;
+ SCM answer = SCM_EOL;
+ SCM *pos = &answer;
var_start (foo, elt);
- answer = SCM_EOL;
- pos = &answer;
- while (elt != SCM_UNDEFINED)
+ while (! SCM_UNBNDP (elt))
{
*pos = scm_cons (elt, SCM_EOL);
pos = SCM_CDRLOC (*pos);
}
-SCM_DEFINE(scm_list, "list", 0, 0, 1,
+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
{
return objs;
#undef FUNC_NAME
-SCM_DEFINE (scm_list_star, "list*", 1, 0, 1,
+SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1,
(SCM arg, SCM rest),
-"")
-#define FUNC_NAME s_scm_list_star
-{
- if (SCM_NIMP (rest))
+ "Like @code{list}, but the last arg provides the tail of the\n"
+ "constructed list, returning @code{(cons @var{arg1} (cons\n"
+ "@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one\n"
+ "argument. If given one argument, that argument is returned as\n"
+ "result. This function is called @code{list*} in some other\n"
+ "Schemes and in Common LISP.")
+#define FUNC_NAME s_scm_cons_star
+{
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+ if (!SCM_NULLP (rest))
{
SCM prev = arg = scm_cons (arg, rest);
- while (SCM_NIMP (SCM_CDR (rest)))
+ while (SCM_NNULLP (SCM_CDR (rest)))
{
prev = rest;
rest = SCM_CDR (rest);
\f
/* general questions about lists --- null?, list?, length, etc. */
-SCM_DEFINE(scm_null_p, "null?", 1, 0, 0,
+SCM_DEFINE (scm_null_p, "null?", 1, 0, 0,
(SCM x),
-"")
+ "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_BOOL (SCM_NULL_OR_NIL_P (x));
}
#undef FUNC_NAME
-SCM_DEFINE(scm_list_p, "list?", 1, 0, 0,
+
+SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
(SCM x),
-"")
+ "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_BOOL (scm_ilength (x) >= 0);
}
#undef FUNC_NAME
long
scm_ilength(SCM sx)
{
- register long i = 0;
- register SCM tortoise = sx;
- register SCM hare = sx;
+ long i = 0;
+ SCM tortoise = sx;
+ SCM hare = sx;
do {
- if (SCM_IMP(hare)) return SCM_NULLP(hare) ? i : -1;
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
if (SCM_NCONSP(hare)) return -1;
hare = SCM_CDR(hare);
i++;
- if (SCM_IMP(hare)) return SCM_NULLP(hare) ? i : -1;
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
if (SCM_NCONSP(hare)) return -1;
hare = SCM_CDR(hare);
i++;
/* For every two steps the hare takes, the tortoise takes one. */
tortoise = SCM_CDR(tortoise);
}
- while (hare != tortoise);
+ while (! SCM_EQ_P (hare, tortoise));
/* If the tortoise ever catches the hare, then the list must contain
a cycle. */
return -1;
}
-SCM_DEFINE(scm_length, "length", 1, 0, 0,
+
+SCM_DEFINE (scm_length, "length", 1, 0, 0,
(SCM lst),
-"")
+ "Return the number of elements in list @var{lst}.")
#define FUNC_NAME s_scm_length
{
- int i;
- SCM_VALIDATE_LIST_COPYLEN(1,lst,i);
+ long i;
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, i);
return SCM_MAKINUM (i);
}
#undef FUNC_NAME
SCM_DEFINE (scm_append, "append", 0, 0, 1,
(SCM args),
-"A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,
-The Revised^4 Report on Scheme}). The cdr field of each list's final
-pair is changed to point to the head of the next list, so no consing is
-performed. Return a pointer to the mutated list.")
+ "Return a list consisting of the elements the lists passed as\n"
+ "arguments.\n"
+ "@lisp\n"
+ "(append '(x) '(y)) @result{} (x y)\n"
+ "(append '(a) '(b c d)) @result{} (a b c d)\n"
+ "(append '(a (b)) '((c))) @result{} (a (b) (c))\n"
+ "@end lisp\n"
+ "The resulting list is always newly allocated, except that it\n"
+ "shares structure with the last list argument. The last\n"
+ "argument may actually be any object; an improper list results\n"
+ "if the last argument is not a proper list.\n"
+ "@lisp\n"
+ "(append '(a b) '(c . d)) @result{} (a b c . d)\n"
+ "(append '() 'a) @result{} a\n"
+ "@end lisp")
#define FUNC_NAME s_scm_append
{
- SCM res = SCM_EOL;
- SCM *lloc = &res, arg;
- if (SCM_IMP(args)) {
- SCM_VALIDATE_NULL(SCM_ARGn, args);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (SCM_NULLP (args)) {
+ return SCM_EOL;
+ } else {
+ SCM res = SCM_EOL;
+ SCM *lloc = &res;
+ SCM arg = SCM_CAR (args);
+ args = SCM_CDR (args);
+ while (!SCM_NULLP (args)) {
+ while (SCM_CONSP (arg)) {
+ *lloc = scm_cons (SCM_CAR (arg), SCM_EOL);
+ lloc = SCM_CDRLOC (*lloc);
+ arg = SCM_CDR (arg);
+ }
+ SCM_VALIDATE_NULL_OR_NIL (SCM_ARGn, arg);
+ arg = SCM_CAR (args);
+ args = SCM_CDR (args);
+ };
+ *lloc = arg;
return res;
}
- SCM_VALIDATE_CONS(SCM_ARGn, args);
- while (1) {
- arg = SCM_CAR(args);
- args = SCM_CDR(args);
- if (SCM_IMP(args)) {
- *lloc = arg;
- SCM_VALIDATE_NULL(SCM_ARGn, args);
- return res;
- }
- SCM_VALIDATE_CONS(SCM_ARGn, args);
- for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) {
- SCM_VALIDATE_CONS(SCM_ARGn, arg);
- *lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
- lloc = SCM_CDRLOC(*lloc);
- }
- SCM_VALIDATE_NULL(SCM_ARGn, arg);
- }
}
#undef FUNC_NAME
SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
- (SCM args),
-"")
+ (SCM lists),
+ "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 mutated list.")
#define FUNC_NAME s_scm_append_x
{
- SCM arg;
- tail:
- if (SCM_NULLP(args)) return SCM_EOL;
- arg = SCM_CAR(args);
- args = SCM_CDR(args);
- if (SCM_NULLP(args)) return arg;
- if (SCM_NULLP(arg)) goto tail;
- SCM_VALIDATE_CONS(SCM_ARG1,arg);
- SCM_SETCDR (scm_last_pair (arg), scm_append_x (args));
- return arg;
+ SCM_VALIDATE_REST_ARGUMENT (lists);
+ while (1) {
+ if (SCM_NULLP (lists)) {
+ return SCM_EOL;
+ } else {
+ SCM arg = SCM_CAR (lists);
+ lists = SCM_CDR (lists);
+ if (SCM_NULLP (lists)) {
+ return arg;
+ } else if (!SCM_NULL_OR_NIL_P (arg)) {
+ SCM_VALIDATE_CONS (SCM_ARG1, arg);
+ SCM_SETCDR (scm_last_pair (arg), scm_append_x (lists));
+ return arg;
+ }
+ }
+ }
}
#undef FUNC_NAME
-SCM_DEFINE(scm_last_pair, "last-pair", 1, 0, 0,
- (SCM sx),
-"Return a pointer to the last pair in @var{lst}, signalling an error if
-@var{lst} is circular.")
+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"
+ "@var{lst} is circular.")
#define FUNC_NAME s_scm_last_pair
{
- register SCM res = sx;
- register SCM x;
+ SCM tortoise = lst;
+ SCM hare = lst;
- if (SCM_NULLP (sx))
- return SCM_EOL;
+ if (SCM_NULL_OR_NIL_P (lst))
+ return lst;
- SCM_VALIDATE_CONS(SCM_ARG1,res);
- while (!0) {
- x = SCM_CDR(res);
- if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
- res = x;
- x = SCM_CDR(res);
- if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
- res = x;
- sx = SCM_CDR(sx);
- SCM_ASSERT(x != sx, sx, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_CONS (SCM_ARG1, lst);
+ do {
+ SCM ahead = SCM_CDR(hare);
+ if (SCM_NCONSP(ahead)) return hare;
+ hare = ahead;
+ ahead = SCM_CDR(hare);
+ if (SCM_NCONSP(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_list_1 (lst));
}
#undef FUNC_NAME
/* reversing lists */
SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
- (SCM ls),
-"A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs,
-The Revised^4 Report on Scheme}). The cdr of each cell in @var{lst} is
-modified to point to the previous list element. Return a pointer to the
-head of the reversed list.
-
-Caveat: because the list is modified in place, the tail of the original
-list now becomes its head, and the head of the original list now becomes
-the tail. Therefore, the @var{lst} symbol to which the head of the
-original list was bound now points to the tail. To ensure that the head
-of the modified list is not lost, it is wise to save the return value of
-@code{reverse!}")
+ (SCM lst),
+ "Return a new list that contains the elements of @var{lst} but\n"
+ "in reverse order.")
#define FUNC_NAME s_scm_reverse
{
- SCM res = SCM_EOL;
- SCM p = ls, t = ls;
- while (SCM_NIMP (p))
- {
- SCM_VALIDATE_CONS(1,ls);
- res = scm_cons (SCM_CAR (p), res);
- p = SCM_CDR (p);
- if (SCM_IMP (p))
- break;
- SCM_VALIDATE_CONS(1,ls);
- res = scm_cons (SCM_CAR (p), res);
- p = SCM_CDR (p);
- t = SCM_CDR (t);
- if (t == p)
- scm_misc_error (FUNC_NAME, "Circular structure: %S", SCM_LIST1 (ls));
+ SCM result = SCM_EOL;
+ SCM tortoise = lst;
+ SCM hare = lst;
+
+ do {
+ if (SCM_NULL_OR_NIL_P(hare)) return result;
+ SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME);
+ result = scm_cons (SCM_CAR (hare), result);
+ hare = SCM_CDR (hare);
+ if (SCM_NULL_OR_NIL_P(hare)) return result;
+ SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME);
+ result = scm_cons (SCM_CAR (hare), result);
+ hare = SCM_CDR (hare);
+ tortoise = SCM_CDR (tortoise);
}
- ls = p;
- SCM_VALIDATE_NULL(1,ls);
- return res;
+ while (! SCM_EQ_P (hare, tortoise));
+ SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
}
#undef FUNC_NAME
SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
- (SCM ls, SCM new_tail),
-"")
+ (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"
+ "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"
+ "original list was bound now points to the tail. To ensure that the head\n"
+ "of the modified list is not lost, it is wise to save the return value of\n"
+ "@code{reverse!}")
#define FUNC_NAME s_scm_reverse_x
{
- SCM old_tail;
- SCM_ASSERT (scm_ilength (ls) >= 0, ls, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_LIST (1, lst);
if (SCM_UNBNDP (new_tail))
new_tail = SCM_EOL;
else
- SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, new_tail);
- while (SCM_NIMP (ls))
+ while (!SCM_NULL_OR_NIL_P (lst))
{
- old_tail = SCM_CDR (ls);
- SCM_SETCDR (ls, new_tail);
- new_tail = ls;
- ls = old_tail;
+ SCM old_tail = SCM_CDR (lst);
+ SCM_SETCDR (lst, new_tail);
+ new_tail = lst;
+ lst = old_tail;
}
return new_tail;
}
#undef FUNC_NAME
-
\f
+
/* indexing lists by element number */
-SCM_DEFINE(scm_list_ref, "list-ref", 2, 0, 0,
- (SCM lst, SCM k),
-"")
+SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
+ (SCM list, SCM k),
+ "Return the @var{k}th element from @var{list}.")
#define FUNC_NAME s_scm_list_ref
{
- register long i;
- SCM_VALIDATE_INUM_MIN_COPY(2,k,0,i);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
- erout:
- SCM_ASSERT(SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
- return SCM_CAR(lst);
+ SCM lst = list;
+ unsigned long int i;
+ SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i);
+ while (SCM_CONSP (lst)) {
+ if (i == 0)
+ return SCM_CAR (lst);
+ else {
+ --i;
+ lst = SCM_CDR (lst);
+ }
+ };
+ if (SCM_NULL_OR_NIL_P (lst))
+ SCM_OUT_OF_RANGE (2, k);
+ else
+ SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME
-SCM_DEFINE(scm_list_set_x, "list-set!", 3, 0, 0,
- (SCM lst, SCM k, SCM val),
-"Set the @var{k}th element of @var{lst} to @var{val}.")
+
+SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
+ (SCM list, SCM k, SCM val),
+ "Set the @var{k}th element of @var{list} to @var{val}.")
#define FUNC_NAME s_scm_list_set_x
{
- register long i;
- SCM_VALIDATE_INUM_MIN_COPY(2,k,0,i);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
- erout:
- SCM_ASSERT(SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
- SCM_SETCAR (lst, val);
- return val;
+ SCM lst = list;
+ unsigned long int i;
+ SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i);
+ while (SCM_CONSP (lst)) {
+ if (i == 0) {
+ SCM_SETCAR (lst, val);
+ return val;
+ } else {
+ --i;
+ lst = SCM_CDR (lst);
+ }
+ };
+ if (SCM_NULL_OR_NIL_P (lst))
+ SCM_OUT_OF_RANGE (2, k);
+ else
+ SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME
SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
-SCM_DEFINE(scm_list_tail, "list-tail", 2, 0, 0,
+SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
(SCM lst, SCM k),
-"Return the \"tail\" of @var{lst} beginning with its @var{k}th element.
-The first element of the list is considered to be element 0.
-
-@code{list-cdr-ref} and @code{list-tail} are identical. It may help to
-think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,
-or returning the results of cdring @var{k} times down @var{lst}.")
+ "@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"
+ "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\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);
+ SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i);
while (i-- > 0) {
- SCM_VALIDATE_CONS(1,lst);
+ SCM_VALIDATE_CONS (1, lst);
lst = SCM_CDR(lst);
}
return lst;
#undef FUNC_NAME
-SCM_DEFINE(scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
- (SCM lst, SCM k, SCM val),
-"Set the @var{k}th cdr of @var{lst} to @var{val}.")
+SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
+ (SCM list, SCM k, SCM val),
+ "Set the @var{k}th cdr of @var{list} to @var{val}.")
#define FUNC_NAME s_scm_list_cdr_set_x
{
- register long i;
- SCM_VALIDATE_INUM_MIN_COPY(2,k,0,i);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
-erout:
- SCM_ASSERT(SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
- SCM_SETCDR (lst, val);
- return val;
+ SCM lst = list;
+ unsigned long int i;
+ SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i);
+ while (SCM_CONSP (lst)) {
+ if (i == 0) {
+ SCM_SETCDR (lst, val);
+ return val;
+ } else {
+ --i;
+ lst = SCM_CDR (lst);
+ }
+ };
+ if (SCM_NULL_OR_NIL_P (lst))
+ SCM_OUT_OF_RANGE (2, k);
+ else
+ SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME
\f
/* copying lists, perhaps partially */
-SCM_DEFINE(scm_list_head, "list-head", 2, 0, 0,
+SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
(SCM lst, SCM k),
-"Copy the first @var{k} elements from @var{lst} into a new list, and
-return it.")
+ "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
+ "return it.")
#define FUNC_NAME s_scm_list_head
{
SCM answer;
SCM * pos;
register long i;
- SCM_VALIDATE_INUM_MIN_COPY(2,k,0,i);
+ 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);
SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
(SCM lst),
-"Return a (newly-created) copy of @var{lst}.")
+ "Return a (newly-created) copy of @var{lst}.")
#define FUNC_NAME s_scm_list_copy
{
SCM newlst;
SCM * fill_here;
SCM from_here;
+ SCM_VALIDATE_LIST (1, lst);
+
newlst = SCM_EOL;
fill_here = &newlst;
from_here = lst;
\f
/* membership tests (memq, memv, etc.) */
-SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
- (SCM x, SCM lst),
-"@deffnx primitive sloppy-memv
-@deffnx primitive sloppy-member
-These procedures behave like @code{memq}, @code{memv} and @code{member}
-(@pxref{Pairs and Lists,,,r4rs, The Revised^4 Report on Scheme}), but do
-not perform any type or error checking. Their use is recommended only
-in writing Guile internals, not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memq
-{
- for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (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),
-"")
-#define FUNC_NAME s_scm_sloppy_memv
-{
- for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR(lst), x))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
- (SCM x, SCM lst),
-"")
-#define FUNC_NAME s_scm_sloppy_member
+/* 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
+ * (list-tail list k) for k less than the length of list. If obj does not
+ * occur in list, then #f (not the empty list) is returned.
+ * List must be a proper list, otherwise scm_c_memq may crash or loop
+ * endlessly.
+ */
+SCM
+scm_c_memq (SCM obj, SCM list)
{
- for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
+ for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list))
{
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR(lst), x))
- return lst;
+ if (SCM_EQ_P (SCM_CAR (list), obj))
+ return list;
}
- return lst;
+ return SCM_BOOL_F;
}
-#undef FUNC_NAME
-
-SCM_DEFINE(scm_memq, "memq", 2, 0, 0,
+SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
(SCM x, SCM lst),
-"")
+ "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
+ "to @var{x} where the sublists of @var{lst} are the non-empty\n"
+ "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
+ "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
+ "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
+ "returned.")
#define FUNC_NAME s_scm_memq
{
- SCM answer;
- SCM_VALIDATE_LIST(2,lst);
- answer = scm_sloppy_memq (x, lst);
- return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
+ SCM_VALIDATE_LIST (2, lst);
+ return scm_c_memq (x, lst);
}
#undef FUNC_NAME
-
-SCM_DEFINE(scm_memv, "memv", 2, 0, 0,
+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"
+ "to @var{x} where the sublists of @var{lst} are the non-empty\n"
+ "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
+ "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
+ "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
+ "returned.")
#define FUNC_NAME s_scm_memv
{
- SCM answer;
- SCM_VALIDATE_LIST(2,lst);
- answer = scm_sloppy_memv (x, lst);
- return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
+ SCM_VALIDATE_LIST (2, lst);
+ for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
+ {
+ if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst), x)))
+ return lst;
+ }
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
-SCM_DEFINE(scm_member, "member", 2, 0, 0,
+SCM_DEFINE (scm_member, "member", 2, 0, 0,
(SCM x, SCM lst),
-"")
+ "Return the first sublist of @var{lst} whose car is\n"
+ "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
+ "the non-empty lists returned by @code{(list-tail @var{lst}\n"
+ "@var{k})} for @var{k} less than the length of @var{lst}. If\n"
+ "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
+ "empty list) is returned.")
#define FUNC_NAME s_scm_member
{
- SCM answer;
- SCM_VALIDATE_LIST(2,lst);
- answer = scm_sloppy_member (x, lst);
- return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
+ SCM_VALIDATE_LIST (2, lst);
+ for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
+ {
+ if (! SCM_FALSEP (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_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
(SCM item, SCM lst),
-"@deffnx primitive delv! item lst
-@deffnx primitive delete! item lst
-These procedures are destructive versions of @code{delq}, @code{delv}
-and @code{delete}: they modify the pointers in the existing @var{lst}
-rather than creating a new list. Caveat evaluator: Like other
-destructive list functions, these functions cannot modify the binding of
-@var{lst}, and so cannot be used to delete the first element of
-@var{lst} destructively.")
+ "@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"
+ "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"
+ "@var{lst} destructively.")
#define FUNC_NAME s_scm_delq_x
{
SCM walk;
SCM_CONSP (walk);
walk = SCM_CDR (walk))
{
- if (SCM_CAR (walk) == item)
+ if (SCM_EQ_P (SCM_CAR (walk), item))
*prev = SCM_CDR (walk);
else
prev = SCM_CDRLOC (walk);
#undef FUNC_NAME
-SCM_DEFINE(scm_delv_x, "delv!", 2, 0, 0,
- (SCM item, SCM lst),
-"")
+SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Destructively remove all elements from @var{lst} that are\n"
+ "@code{eqv?} to @var{item}.")
#define FUNC_NAME s_scm_delv_x
{
SCM walk;
SCM_CONSP (walk);
walk = SCM_CDR (walk))
{
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (walk), item))
+ if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk), item)))
*prev = SCM_CDR (walk);
else
prev = SCM_CDRLOC (walk);
-SCM_DEFINE(scm_delete_x, "delete!", 2, 0, 0,
- (SCM item, SCM lst),
-"")
+SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Destructively remove all elements from @var{lst} that are\n"
+ "@code{equal?} to @var{item}.")
#define FUNC_NAME s_scm_delete_x
{
SCM walk;
SCM_CONSP (walk);
walk = SCM_CDR (walk))
{
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR (walk), item))
+ if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk), item)))
*prev = SCM_CDR (walk);
else
prev = SCM_CDRLOC (walk);
SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
(SCM item, SCM lst),
-"@deffnx primitive delv item lst
-@deffnx primitive delete item lst
-Return a newly-created copy of @var{lst} with @var{item} removed. These
-procedures mirror @code{memq}, @code{memv} and @code{member}:
-@code{delq} compares elements of @var{lst} against @var{item} with
-@code{eq?}, @code{delv} uses @code{eqv?} and @code{delete} uses @code{equal?}")
+ "Return a newly-created copy of @var{lst} with elements\n"
+ "@code{eq?} to @var{item} removed. This procedure mirrors\n"
+ "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
+ "@var{item} with @code{eq?}.")
#define FUNC_NAME s_scm_delq
{
SCM copy = scm_list_copy (lst);
SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
(SCM item, SCM lst),
-"")
+ "Return a newly-created copy of @var{lst} with elements\n"
+ "@code{eqv?} to @var{item} removed. This procedure mirrors\n"
+ "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
+ "@var{item} with @code{eqv?}.")
#define FUNC_NAME s_scm_delv
{
SCM copy = scm_list_copy (lst);
SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
(SCM item, SCM lst),
-"")
+ "Return a newly-created copy of @var{lst} with elements\n"
+ "@code{equal?} to @var{item} removed. This procedure mirrors\n"
+ "@code{member}: @code{delete} compares elements of @var{lst}\n"
+ "against @var{item} with @code{equal?}.")
#define FUNC_NAME s_scm_delete
{
SCM copy = scm_list_copy (lst);
#undef FUNC_NAME
-SCM_DEFINE(scm_delq1_x, "delq1!", 2, 0, 0,
+SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
(SCM item, SCM lst),
-"")
+ "Like @code{delq!}, but only deletes the first occurrence of\n"
+ "@var{item} from @var{lst}. Tests for equality using\n"
+ "@code{eq?}. See also @code{delv1!} and @code{delete1!}.")
#define FUNC_NAME s_scm_delq1_x
{
SCM walk;
SCM_CONSP (walk);
walk = SCM_CDR (walk))
{
- if (SCM_CAR (walk) == item)
+ if (SCM_EQ_P (SCM_CAR (walk), item))
{
*prev = SCM_CDR (walk);
break;
#undef FUNC_NAME
-SCM_DEFINE(scm_delv1_x, "delv1!", 2, 0, 0,
- (SCM item, SCM lst),
-"")
+SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Like @code{delv!}, but only deletes the first occurrence of\n"
+ "@var{item} from @var{lst}. Tests for equality using\n"
+ "@code{eqv?}. See also @code{delq1!} and @code{delete1!}.")
#define FUNC_NAME s_scm_delv1_x
{
SCM walk;
SCM_CONSP (walk);
walk = SCM_CDR (walk))
{
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (walk), item))
+ if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk), item)))
{
*prev = SCM_CDR (walk);
break;
#undef FUNC_NAME
-SCM_DEFINE(scm_delete1_x, "delete1!", 2, 0, 0,
- (SCM item, SCM lst),
-"")
+SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Like @code{delete!}, but only deletes the first occurrence of\n"
+ "@var{item} from @var{lst}. Tests for equality using\n"
+ "@code{equal?}. See also @code{delq1!} and @code{delv1!}.")
#define FUNC_NAME s_scm_delete1_x
{
SCM walk;
SCM_CONSP (walk);
walk = SCM_CDR (walk))
{
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR (walk), item))
+ if (! SCM_FALSEP (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_CONSP (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (!SCM_FALSEP (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_CONSP (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (!SCM_FALSEP (call (pred, SCM_CAR (walk))))
+ prev = SCM_CDRLOC (walk);
+ else
+ *prev = SCM_CDR (walk);
+ }
+
+ return list;
+}
+#undef FUNC_NAME
\f
void
scm_init_list ()
{
-#include "list.x"
+#include "libguile/list.x"
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff