X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/8f85c0c6c3eb8de857babc08ca6e832e8a497c44..c614a00b8c155b59c76c0fe1e272aa2df1f3faf5:/libguile/list.c diff --git a/libguile/list.c b/libguile/list.c index b709b882d..41ff2c3fb 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,2000,2001 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 @@ -43,9 +43,11 @@ #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 @@ -58,11 +60,9 @@ /* creating lists */ -#define SCM_I_CONS(cell,x,y) \ +#define SCM_I_CONS(cell, x, y) \ do { \ - SCM_NEWCELL (cell); \ - SCM_SET_CELL_OBJECT_1 (cell, y); \ - SCM_SET_CELL_OBJECT_0 (cell, x); \ + cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y); \ } while (0) SCM @@ -167,7 +167,7 @@ SCM_DEFINE (scm_null_p, "null?", 1, 0, 0, "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 @@ -194,11 +194,11 @@ scm_ilength(SCM sx) SCM hare = sx; do { - if (SCM_NULLP(hare)) return i; + if (SCM_NULL_OR_NIL_P(hare)) return i; if (SCM_NCONSP(hare)) return -1; hare = SCM_CDR(hare); i++; - if (SCM_NULLP(hare)) return i; + if (SCM_NULL_OR_NIL_P(hare)) return i; if (SCM_NCONSP(hare)) return -1; hare = SCM_CDR(hare); i++; @@ -219,7 +219,7 @@ SCM_DEFINE (scm_length, "length", 1, 0, 0, #define FUNC_NAME s_scm_length { long i; - SCM_VALIDATE_LIST_COPYLEN (1,lst,i); + SCM_VALIDATE_LIST_COPYLEN (1, lst, i); return SCM_MAKINUM (i); } #undef FUNC_NAME @@ -261,7 +261,7 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, lloc = SCM_CDRLOC (*lloc); arg = SCM_CDR (arg); } - SCM_VALIDATE_NULL (SCM_ARGn, arg); + SCM_VALIDATE_NULL_OR_NIL (SCM_ARGn, arg); arg = SCM_CAR (args); args = SCM_CDR (args); }; @@ -290,7 +290,7 @@ SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, lists = SCM_CDR (lists); if (SCM_NULLP (lists)) { return arg; - } else if (!SCM_NULLP (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; @@ -310,8 +310,8 @@ SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, 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 { @@ -342,11 +342,11 @@ SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, SCM hare = lst; do { - if (SCM_NULLP(hare)) return result; + 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_NULLP(hare)) return result; + 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); @@ -377,7 +377,7 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, 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); @@ -399,7 +399,7 @@ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, { SCM lst = list; unsigned long int i; - SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); + SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i); while (SCM_CONSP (lst)) { if (i == 0) return SCM_CAR (lst); @@ -408,7 +408,7 @@ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, 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); @@ -423,7 +423,7 @@ SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, { SCM lst = list; unsigned long int i; - SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); + SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i); while (SCM_CONSP (lst)) { if (i == 0) { SCM_SETCAR (lst, val); @@ -433,7 +433,7 @@ SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, 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); @@ -454,9 +454,9 @@ SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, #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; @@ -471,7 +471,7 @@ SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, { SCM lst = list; unsigned long int i; - SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i); + SCM_VALIDATE_INUM_MIN_COPY (2, k,0, i); while (SCM_CONSP (lst)) { if (i == 0) { SCM_SETCDR (lst, val); @@ -481,7 +481,7 @@ SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, 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); @@ -502,12 +502,12 @@ SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0, 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); @@ -557,7 +557,7 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, 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)) return list; @@ -593,7 +593,7 @@ SCM_DEFINE (scm_memv, "memv", 2, 0, 0, #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))) return lst; @@ -614,7 +614,7 @@ SCM_DEFINE (scm_member, "member", 2, 0, 0, #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))) return lst; @@ -831,14 +831,70 @@ 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_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 void scm_init_list () { -#ifndef SCM_MAGIC_SNARFER #include "libguile/list.x" -#endif } /*