X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/33d0abd7e1f8eed72abd544d0b2b5bf158454131..e6c8e6047ed2e772cc4e1fb5ad4d389e5c616feb:/libguile/list.c diff --git a/libguile/list.c b/libguile/list.c index 25aac038f..d30f9e847 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -1,121 +1,152 @@ -/* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010,2011 + * 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 3 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 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. * - * 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. - * - * 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 */ -#include +#ifdef HAVE_CONFIG_H +# include +#endif + #include "libguile/_scm.h" #include "libguile/eq.h" #include "libguile/validate.h" #include "libguile/list.h" +#include "libguile/eval.h" -#ifdef __STDC__ #include -#define var_start(x, y) va_start(x, y) -#else -#include -#define var_start(x, y) va_start(x) -#endif /* creating lists */ +#define SCM_I_CONS(cell, x, y) \ + do { \ + cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (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 OBJS, the arguments to `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_DEBUG_DEPRECATED == 0) + if (SCM_UNBNDP (init)) + init = SCM_EOL; -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 `list', but the last arg provides the tail of the constructed list,\n" - "returning (cons ARG1 (cons ARG2 (cons ... ARGn))).\n" - "Requires at least one argument. If given one argument, that argument\n" - "is returned as result.\n" - "This function is called `list*' in some other Schemes and in Common LISP.") + "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 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 @@ -125,20 +156,20 @@ SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1, SCM_DEFINE (scm_null_p, "null?", 1, 0, 0, (SCM x), - "Return #t iff X is the empty list, else #f.") + "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 SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, (SCM x), - "Return #t iff X is a proper list, else #f.") + "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 @@ -155,18 +186,18 @@ scm_ilength(SCM sx) 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. */ @@ -176,12 +207,12 @@ scm_ilength(SCM sx) SCM_DEFINE (scm_length, "length", 1, 0, 0, (SCM lst), - "Return the number of elements in list 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); - return SCM_MAKINUM (i); + long i; + SCM_VALIDATE_LIST_COPYLEN (1, lst, i); + return scm_from_long (i); } #undef FUNC_NAME @@ -191,39 +222,42 @@ SCM_DEFINE (scm_length, "length", 1, 0, 0, SCM_DEFINE (scm_append, "append", 0, 0, 1, (SCM args), - "Returns a list consisting of the elements of the first LIST\n" - "followed by the elements of the other LISTs.\n" - "\n" - " (append '(x) '(y)) => (x y)\n" - " (append '(a) '(b c d)) => (a b c d)\n" - " (append '(a (b)) '((c))) => (a (b) (c))\n" - "\n" - "The resulting list is always newly allocated, except that it shares\n" - "structure with the last LIST argument. The last argument may\n" - "actually be any object; an improper list results if the last\n" - "argument is not a proper list.\n" - - " (append '(a b) '(c . d)) => (a b c . d)\n" - " (append '() 'a) => a\n") + "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_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; @@ -234,56 +268,66 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, (SCM args), - "A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,\n" - "The Revised^4 Report on Scheme}). The cdr field of each list's final\n" - "pair is changed to point to the head of the next list, so no consing is\n" - "performed. Return a pointer to the mutated list.") + "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\n" + "the mutated list.") #define FUNC_NAME s_scm_append_x { + SCM ret, *loc; + int argnum = 1; SCM_VALIDATE_REST_ARGUMENT (args); - while (1) { - if (SCM_NULLP (args)) { - return SCM_EOL; - } else { + + if (scm_is_null (args)) + return SCM_EOL; + + loc = &ret; + for (;;) + { SCM arg = SCM_CAR (args); + *loc = arg; + args = SCM_CDR (args); - if (SCM_NULLP (args)) { - return arg; - } else if (!SCM_NULLP (arg)) { - SCM_VALIDATE_CONS (SCM_ARG1, arg); - SCM_SETCDR (scm_last_pair (arg), scm_append_x (args)); - return arg; - } + if (scm_is_null (args)) + return ret; + + if (!SCM_NULL_OR_NIL_P (arg)) + { + SCM_VALIDATE_CONS (argnum, arg); + loc = SCM_CDRLOC (scm_last_pair (arg)); + SCM_VALIDATE_NULL_OR_NIL (argnum, *loc); + } + argnum++; } - } } #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 @@ -292,7 +336,8 @@ SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, (SCM lst), - "Return a new list that contains the elements of LST but in reverse order.") + "Return a new list that contains the elements of @var{lst} but\n" + "in reverse order.") #define FUNC_NAME s_scm_reverse { SCM result = SCM_EOL; @@ -300,27 +345,27 @@ SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, 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_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, (SCM lst, SCM new_tail), - "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs,\n" - "The Revised^4 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" + "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 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" @@ -329,13 +374,11 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, "@code{reverse!}") #define FUNC_NAME s_scm_reverse_x { - SCM_ASSERT (scm_ilength (lst) >= 0, lst, 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); - while (SCM_NNULLP (lst)) + while (!SCM_NULL_OR_NIL_P (lst)) { SCM old_tail = SCM_CDR (lst); SCM_SETCDR (lst, new_tail); @@ -346,44 +389,54 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, } #undef FUNC_NAME - + /* indexing lists by element number */ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, - (SCM lst, SCM k), - "Return the Kth element from list LST.") + (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; + i = scm_to_ulong (k); + while (scm_is_pair (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 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_to_ulong (k); + while (scm_is_pair (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 @@ -392,17 +445,17 @@ 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 lst, SCM k), + "@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-cdr-ref} and @code{list-tail} are identical. It may help to\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); + 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; @@ -411,21 +464,25 @@ SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, 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 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; + size_t i = scm_to_size_t (k); + while (scm_is_pair (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 @@ -441,14 +498,13 @@ SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0, { 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); @@ -458,6 +514,34 @@ SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0, #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}.") @@ -467,11 +551,13 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, SCM * fill_here; SCM from_here; + SCM_VALIDATE_LIST (1, lst); + newlst = SCM_EOL; 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)); @@ -483,122 +569,154 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, } #undef FUNC_NAME - -/* membership tests (memq, memv, etc.) */ - -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_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_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 + +/* 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 + * (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_FALSEP (scm_equal_p (SCM_CAR (lst), x))) - return lst; + if (scm_is_eq (SCM_CAR (list), obj)) + return list; } - return lst; + return SCM_BOOL_F; } -#undef FUNC_NAME - SCM_DEFINE (scm_memq, "memq", 2, 0, 0, (SCM x, SCM lst), - "Return the first sublist of LST whose car is `eq?' to X\n" - "where the sublists of LST are the non-empty lists returned\n" - "by `(list-tail LST K)' for K less than the length of LST. If\n" - "X does not occur in LST, then `#f' (not the empty list) is\n" - "returned.") + "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 (SCM_NULLP (answer)) ? SCM_BOOL_F : answer; + SCM hare = lst, tortoise = lst; + + while (scm_is_pair (hare)) + { + if (scm_is_eq (SCM_CAR (hare), x)) + return hare; + else + hare = SCM_CDR (hare); + + if (!scm_is_pair (hare)) + break; + + if (scm_is_eq (SCM_CAR (hare), x)) + return hare; + else + hare = SCM_CDR (hare); + + tortoise = SCM_CDR (tortoise); + if (SCM_UNLIKELY (scm_is_eq (hare, tortoise))) + break; + } + + if (SCM_LIKELY (scm_is_null (hare))) + return SCM_BOOL_F; + else + scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list"); } #undef FUNC_NAME - SCM_DEFINE (scm_memv, "memv", 2, 0, 0, (SCM x, SCM lst), - "Return the first sublist of LST whose car is `eqv?' to X\n" - "where the sublists of LST are the non-empty lists returned\n" - "by `(list-tail LST K)' for K less than the length of LST. If\n" - "X does not occur in LST, then `#f' (not the empty list) is\n" - "returned.") + "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 (SCM_NULLP (answer)) ? SCM_BOOL_F : answer; + SCM hare = lst, tortoise = lst; + + while (scm_is_pair (hare)) + { + if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x))) + return hare; + else + hare = SCM_CDR (hare); + + if (!scm_is_pair (hare)) + break; + + if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x))) + return hare; + else + hare = SCM_CDR (hare); + + tortoise = SCM_CDR (tortoise); + if (SCM_UNLIKELY (scm_is_eq (hare, tortoise))) + break; + } + + if (SCM_LIKELY (scm_is_null (hare))) + return SCM_BOOL_F; + else + scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list"); } #undef FUNC_NAME SCM_DEFINE (scm_member, "member", 2, 0, 0, (SCM x, SCM lst), - "Return the first sublist of LST whose car is `equal?' to X\n" - "where the sublists of LST are the non-empty lists returned\n" - "by `(list-tail LST K)' for K less than the length of LST. If\n" - "X does not occur in LST, then `#f' (not the empty list) is\n" - "returned.") + "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 (SCM_NULLP (answer)) ? SCM_BOOL_F : answer; + SCM_VALIDATE_LIST (2, lst); + for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst)) + { + if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x))) + return lst; + } + return SCM_BOOL_F; } #undef FUNC_NAME - /* 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" @@ -609,10 +727,10 @@ SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0, 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); @@ -624,18 +742,19 @@ SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0, SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0, - (SCM item, SCM lst), - "Destructively remove all elements from LST that are `eqv?' to ITEM.") + (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 *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); @@ -648,18 +767,19 @@ SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0, SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0, - (SCM item, SCM lst), - "Destructively remove all elements from LST that are `equal?' to ITEM.") + (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 *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); @@ -675,10 +795,10 @@ SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0, SCM_DEFINE (scm_delq, "delq", 2, 0, 0, (SCM item, SCM lst), - "Return a newly-created copy of @var{lst} with elements `eq?' to @var{item} removed.\n" - "This procedure mirrors @code{memq}:\n" - "@code{delq} compares elements of @var{lst} against @var{item} with\n" - "@code{eq?}.") + "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); @@ -688,10 +808,10 @@ SCM_DEFINE (scm_delq, "delq", 2, 0, 0, SCM_DEFINE (scm_delv, "delv", 2, 0, 0, (SCM item, SCM lst), - "Return a newly-created copy of @var{lst} with elements `eqv?' to @var{item} removed.\n" - "This procedure mirrors @code{memv}:\n" - "@code{delv} compares elements of @var{lst} against @var{item} with\n" - "@code{eqv?}.") + "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); @@ -701,10 +821,10 @@ SCM_DEFINE (scm_delv, "delv", 2, 0, 0, SCM_DEFINE (scm_delete, "delete", 2, 0, 0, (SCM item, SCM lst), - "Return a newly-created copy of @var{lst} with elements `equal?' to @var{item} removed.\n" - "This procedure mirrors @code{member}:\n" - "@code{delete} compares elements of @var{lst} against @var{item} with\n" - "@code{equal?}.") + "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); @@ -715,18 +835,19 @@ SCM_DEFINE (scm_delete, "delete", 2, 0, 0, SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0, (SCM item, SCM lst), - "Like `delq!', but only deletes the first occurrence of ITEM from LST.\n" - "Tests for equality using `eq?'. See also `delv1!' and `delete1!'.") + "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 *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; @@ -742,18 +863,19 @@ SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0, SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0, (SCM item, SCM lst), - "Like `delv!', but only deletes the first occurrence of ITEM from LST.\n" - "Tests for equality using `eqv?'. See also `delq1!' and `delete1!'.") + "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 *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; @@ -769,18 +891,19 @@ SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0, SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0, (SCM item, SCM lst), - "Like `delete!', but only deletes the first occurrence of ITEM from LST.\n" - "Tests for equality using `equal?'. See also `delq1!' and `delv1!'.") + "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 *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; @@ -793,6 +916,62 @@ SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0, } #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 walk; + SCM *prev; + SCM res = SCM_EOL; + SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), 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 (scm_call_1 (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 walk; + SCM *prev; + SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), 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 (scm_call_1 (pred, SCM_CAR (walk)))) + prev = SCM_CDRLOC (walk); + else + *prev = SCM_CDR (walk); + } + + return list; +} +#undef FUNC_NAME void