Commit | Line | Data |
---|---|---|
3b7f4ba3 | 1 | /* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010,2011 |
212e58ed | 2 | * Free Software Foundation, Inc. |
0f2d19dd | 3 | * |
73be1d9e | 4 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
5 | * modify it under the terms of the GNU Lesser General Public License |
6 | * as published by the Free Software Foundation; either version 3 of | |
7 | * the License, or (at your option) any later version. | |
0f2d19dd | 8 | * |
53befeb7 NJ |
9 | * This library is distributed in the hope that it will be useful, but |
10 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | * Lesser General Public License for more details. | |
0f2d19dd | 13 | * |
73be1d9e MV |
14 | * You should have received a copy of the GNU Lesser General Public |
15 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
17 | * 02110-1301 USA | |
73be1d9e | 18 | */ |
1bbd0b84 | 19 | |
1bbd0b84 | 20 | |
0f2d19dd | 21 | \f |
dbb605f5 LC |
22 | #ifdef HAVE_CONFIG_H |
23 | # include <config.h> | |
24 | #endif | |
25 | ||
a0599745 MD |
26 | #include "libguile/_scm.h" |
27 | #include "libguile/eq.h" | |
20e6290e | 28 | |
a0599745 MD |
29 | #include "libguile/validate.h" |
30 | #include "libguile/list.h" | |
c614a00b | 31 | #include "libguile/eval.h" |
0f2d19dd | 32 | |
0f2d19dd | 33 | #include <stdarg.h> |
0f2d19dd JB |
34 | |
35 | \f | |
df13742c | 36 | /* creating lists */ |
0f2d19dd | 37 | |
b2b33168 AW |
38 | #define SCM_I_CONS(cell, x, y) \ |
39 | do { \ | |
40 | cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); \ | |
41 | } while (0) | |
1afff620 KN |
42 | |
43 | SCM | |
44 | scm_list_1 (SCM e1) | |
45 | { | |
46 | SCM c1; | |
47 | SCM_I_CONS (c1, e1, SCM_EOL); | |
48 | return c1; | |
49 | } | |
50 | ||
51 | SCM | |
52 | scm_list_2 (SCM e1, SCM e2) | |
53 | { | |
54 | SCM c1, c2; | |
55 | SCM_I_CONS (c2, e2, SCM_EOL); | |
56 | SCM_I_CONS (c1, e1, c2); | |
57 | return c1; | |
58 | } | |
59 | ||
60 | SCM | |
61 | scm_list_3 (SCM e1, SCM e2, SCM e3) | |
62 | { | |
63 | SCM c1, c2, c3; | |
64 | SCM_I_CONS (c3, e3, SCM_EOL); | |
65 | SCM_I_CONS (c2, e2, c3); | |
66 | SCM_I_CONS (c1, e1, c2); | |
67 | return c1; | |
68 | } | |
69 | ||
70 | SCM | |
71 | scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4) | |
72 | { | |
73 | return scm_cons2 (e1, e2, scm_list_2 (e3, e4)); | |
74 | } | |
75 | ||
76 | SCM | |
77 | scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5) | |
78 | { | |
79 | return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5)); | |
80 | } | |
81 | ||
0f2d19dd | 82 | SCM |
1afff620 | 83 | scm_list_n (SCM elt, ...) |
0f2d19dd JB |
84 | { |
85 | va_list foo; | |
2de14ecd GB |
86 | SCM answer = SCM_EOL; |
87 | SCM *pos = &answer; | |
0f2d19dd | 88 | |
0dbfb25a | 89 | va_start (foo, elt); |
fbd485ba | 90 | while (! SCM_UNBNDP (elt)) |
0f2d19dd | 91 | { |
1e55d288 | 92 | #if (SCM_DEBUG_CELL_ACCESSES == 1) |
8c5bb729 | 93 | if (SCM_HEAP_OBJECT_P (elt)) |
eb741d98 | 94 | SCM_VALIDATE_CELL(elt, 0); |
1e55d288 | 95 | #endif |
0f2d19dd | 96 | *pos = scm_cons (elt, SCM_EOL); |
25d8012c | 97 | pos = SCM_CDRLOC (*pos); |
0f2d19dd JB |
98 | elt = va_arg (foo, SCM); |
99 | } | |
de90ef0f | 100 | va_end (foo); |
0f2d19dd JB |
101 | return answer; |
102 | } | |
103 | ||
104 | ||
2ac6b60e KR |
105 | SCM_DEFINE (scm_make_list, "make-list", 1, 1, 0, |
106 | (SCM n, SCM init), | |
107 | "Create a list containing of @var{n} elements, where each\n" | |
108 | "element is initialized to @var{init}. @var{init} defaults to\n" | |
109 | "the empty list @code{()} if not given.") | |
661ae7ab | 110 | #define FUNC_NAME s_scm_make_list |
2ac6b60e KR |
111 | { |
112 | unsigned nn = scm_to_uint (n); | |
113 | unsigned i; | |
114 | SCM ret = SCM_EOL; | |
115 | ||
116 | if (SCM_UNBNDP (init)) | |
117 | init = SCM_EOL; | |
118 | ||
119 | for (i = 0; i < nn; i++) | |
120 | ret = scm_cons (init, ret); | |
121 | return ret; | |
122 | } | |
123 | #undef FUNC_NAME | |
124 | ||
125 | ||
b906b056 | 126 | SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1, |
1bbd0b84 | 127 | (SCM arg, SCM rest), |
5352393c MG |
128 | "Like @code{list}, but the last arg provides the tail of the\n" |
129 | "constructed list, returning @code{(cons @var{arg1} (cons\n" | |
a17bb5fd | 130 | "@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one\n" |
5352393c MG |
131 | "argument. If given one argument, that argument is returned as\n" |
132 | "result. This function is called @code{list*} in some other\n" | |
133 | "Schemes and in Common LISP.") | |
26a379b2 | 134 | #define FUNC_NAME s_scm_cons_star |
a610b8d9 | 135 | { |
b906b056 KR |
136 | SCM ret = SCM_EOL; |
137 | SCM *p = &ret; | |
138 | ||
af45e3b0 | 139 | SCM_VALIDATE_REST_ARGUMENT (rest); |
b906b056 KR |
140 | |
141 | for ( ; scm_is_pair (rest); rest = SCM_CDR (rest)) | |
a610b8d9 | 142 | { |
b906b056 KR |
143 | *p = scm_cons (arg, SCM_EOL); |
144 | p = SCM_CDRLOC (*p); | |
145 | arg = SCM_CAR (rest); | |
a610b8d9 | 146 | } |
b906b056 KR |
147 | |
148 | *p = arg; | |
149 | return ret; | |
a610b8d9 | 150 | } |
1bbd0b84 | 151 | #undef FUNC_NAME |
a610b8d9 | 152 | |
0f2d19dd JB |
153 | |
154 | \f | |
df13742c | 155 | /* general questions about lists --- null?, list?, length, etc. */ |
0f2d19dd | 156 | |
3b3b36dd | 157 | SCM_DEFINE (scm_null_p, "null?", 1, 0, 0, |
1bbd0b84 | 158 | (SCM x), |
5352393c | 159 | "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.") |
1bbd0b84 | 160 | #define FUNC_NAME s_scm_null_p |
0f2d19dd | 161 | { |
7888309b | 162 | return scm_from_bool (SCM_NULL_OR_NIL_P (x)); |
0f2d19dd | 163 | } |
1bbd0b84 | 164 | #undef FUNC_NAME |
0f2d19dd | 165 | |
2de14ecd | 166 | |
3b3b36dd | 167 | SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, |
1bbd0b84 | 168 | (SCM x), |
5352393c | 169 | "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.") |
1bbd0b84 | 170 | #define FUNC_NAME s_scm_list_p |
0f2d19dd | 171 | { |
7888309b | 172 | return scm_from_bool (scm_ilength (x) >= 0); |
0f2d19dd | 173 | } |
1bbd0b84 | 174 | #undef FUNC_NAME |
0f2d19dd JB |
175 | |
176 | ||
df13742c | 177 | /* Return the length of SX, or -1 if it's not a proper list. |
448a3bc2 | 178 | This uses the "tortoise and hare" algorithm to detect "infinitely |
df13742c JB |
179 | long" lists (i.e. lists with cycles in their cdrs), and returns -1 |
180 | if it does find one. */ | |
c014a02e ML |
181 | long |
182 | scm_ilength(SCM sx) | |
0f2d19dd | 183 | { |
c014a02e | 184 | long i = 0; |
e1385ffc GB |
185 | SCM tortoise = sx; |
186 | SCM hare = sx; | |
df13742c | 187 | |
0f2d19dd | 188 | do { |
c96d76b8 | 189 | if (SCM_NULL_OR_NIL_P(hare)) return i; |
d2e53ed6 | 190 | if (!scm_is_pair (hare)) return -1; |
df13742c | 191 | hare = SCM_CDR(hare); |
0f2d19dd | 192 | i++; |
c96d76b8 | 193 | if (SCM_NULL_OR_NIL_P(hare)) return i; |
d2e53ed6 | 194 | if (!scm_is_pair (hare)) return -1; |
df13742c | 195 | hare = SCM_CDR(hare); |
0f2d19dd | 196 | i++; |
448a3bc2 JB |
197 | /* For every two steps the hare takes, the tortoise takes one. */ |
198 | tortoise = SCM_CDR(tortoise); | |
0f2d19dd | 199 | } |
bc36d050 | 200 | while (!scm_is_eq (hare, tortoise)); |
df13742c | 201 | |
448a3bc2 | 202 | /* If the tortoise ever catches the hare, then the list must contain |
df13742c | 203 | a cycle. */ |
0f2d19dd JB |
204 | return -1; |
205 | } | |
206 | ||
2de14ecd | 207 | |
3b3b36dd | 208 | SCM_DEFINE (scm_length, "length", 1, 0, 0, |
1bbd0b84 | 209 | (SCM lst), |
5352393c | 210 | "Return the number of elements in list @var{lst}.") |
1bbd0b84 | 211 | #define FUNC_NAME s_scm_length |
0f2d19dd | 212 | { |
c014a02e | 213 | long i; |
34d19ef6 | 214 | SCM_VALIDATE_LIST_COPYLEN (1, lst, i); |
e11e83f3 | 215 | return scm_from_long (i); |
0f2d19dd | 216 | } |
1bbd0b84 | 217 | #undef FUNC_NAME |
0f2d19dd JB |
218 | |
219 | ||
220 | \f | |
df13742c | 221 | /* appending lists */ |
0f2d19dd | 222 | |
a1ec6916 | 223 | SCM_DEFINE (scm_append, "append", 0, 0, 1, |
1bbd0b84 | 224 | (SCM args), |
5352393c MG |
225 | "Return a list consisting of the elements the lists passed as\n" |
226 | "arguments.\n" | |
1e6808ea | 227 | "@lisp\n" |
5352393c MG |
228 | "(append '(x) '(y)) @result{} (x y)\n" |
229 | "(append '(a) '(b c d)) @result{} (a b c d)\n" | |
230 | "(append '(a (b)) '((c))) @result{} (a (b) (c))\n" | |
1e6808ea | 231 | "@end lisp\n" |
5352393c MG |
232 | "The resulting list is always newly allocated, except that it\n" |
233 | "shares structure with the last list argument. The last\n" | |
234 | "argument may actually be any object; an improper list results\n" | |
235 | "if the last argument is not a proper list.\n" | |
1e6808ea | 236 | "@lisp\n" |
5352393c MG |
237 | "(append '(a b) '(c . d)) @result{} (a b c . d)\n" |
238 | "(append '() 'a) @result{} a\n" | |
1e6808ea | 239 | "@end lisp") |
1bbd0b84 | 240 | #define FUNC_NAME s_scm_append |
0f2d19dd | 241 | { |
af45e3b0 | 242 | SCM_VALIDATE_REST_ARGUMENT (args); |
d2e53ed6 | 243 | if (scm_is_null (args)) { |
af45e3b0 DH |
244 | return SCM_EOL; |
245 | } else { | |
246 | SCM res = SCM_EOL; | |
247 | SCM *lloc = &res; | |
248 | SCM arg = SCM_CAR (args); | |
4c13270f | 249 | int argnum = 1; |
af45e3b0 | 250 | args = SCM_CDR (args); |
d2e53ed6 MV |
251 | while (!scm_is_null (args)) { |
252 | while (scm_is_pair (arg)) { | |
af45e3b0 DH |
253 | *lloc = scm_cons (SCM_CAR (arg), SCM_EOL); |
254 | lloc = SCM_CDRLOC (*lloc); | |
255 | arg = SCM_CDR (arg); | |
256 | } | |
4c13270f | 257 | SCM_VALIDATE_NULL_OR_NIL (argnum, arg); |
af45e3b0 DH |
258 | arg = SCM_CAR (args); |
259 | args = SCM_CDR (args); | |
4c13270f | 260 | argnum++; |
af45e3b0 DH |
261 | }; |
262 | *lloc = arg; | |
0f2d19dd JB |
263 | return res; |
264 | } | |
0f2d19dd | 265 | } |
1bbd0b84 | 266 | #undef FUNC_NAME |
0f2d19dd JB |
267 | |
268 | ||
a1ec6916 | 269 | SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, |
226a56a3 | 270 | (SCM args), |
1e6808ea | 271 | "A destructive version of @code{append} (@pxref{Pairs and\n" |
7a095584 | 272 | "Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n" |
1e6808ea | 273 | "of each list's final pair is changed to point to the head of\n" |
71a89639 | 274 | "the next list, so no consing is performed. Return\n" |
1e6808ea | 275 | "the mutated list.") |
1bbd0b84 | 276 | #define FUNC_NAME s_scm_append_x |
0f2d19dd | 277 | { |
d4641098 | 278 | SCM ret, *loc; |
226a56a3 MW |
279 | int argnum = 1; |
280 | SCM_VALIDATE_REST_ARGUMENT (args); | |
d4641098 | 281 | |
226a56a3 | 282 | if (scm_is_null (args)) |
d4641098 KR |
283 | return SCM_EOL; |
284 | ||
285 | loc = &ret; | |
286 | for (;;) | |
287 | { | |
226a56a3 | 288 | SCM arg = SCM_CAR (args); |
d4641098 KR |
289 | *loc = arg; |
290 | ||
226a56a3 MW |
291 | args = SCM_CDR (args); |
292 | if (scm_is_null (args)) | |
d4641098 KR |
293 | return ret; |
294 | ||
295 | if (!SCM_NULL_OR_NIL_P (arg)) | |
296 | { | |
226a56a3 | 297 | SCM_VALIDATE_CONS (argnum, arg); |
d4641098 | 298 | loc = SCM_CDRLOC (scm_last_pair (arg)); |
226a56a3 | 299 | SCM_VALIDATE_NULL_OR_NIL (argnum, *loc); |
d4641098 | 300 | } |
226a56a3 | 301 | argnum++; |
af45e3b0 | 302 | } |
0f2d19dd | 303 | } |
1bbd0b84 | 304 | #undef FUNC_NAME |
0f2d19dd JB |
305 | |
306 | ||
3b3b36dd | 307 | SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, |
e1385ffc | 308 | (SCM lst), |
71a89639 | 309 | "Return the last pair in @var{lst}, signalling an error if\n" |
b380b885 | 310 | "@var{lst} is circular.") |
1bbd0b84 | 311 | #define FUNC_NAME s_scm_last_pair |
df13742c | 312 | { |
e1385ffc GB |
313 | SCM tortoise = lst; |
314 | SCM hare = lst; | |
0f2d19dd | 315 | |
c96d76b8 NJ |
316 | if (SCM_NULL_OR_NIL_P (lst)) |
317 | return lst; | |
df13742c | 318 | |
e1385ffc GB |
319 | SCM_VALIDATE_CONS (SCM_ARG1, lst); |
320 | do { | |
321 | SCM ahead = SCM_CDR(hare); | |
d2e53ed6 | 322 | if (!scm_is_pair (ahead)) return hare; |
e1385ffc GB |
323 | hare = ahead; |
324 | ahead = SCM_CDR(hare); | |
d2e53ed6 | 325 | if (!scm_is_pair (ahead)) return hare; |
e1385ffc GB |
326 | hare = ahead; |
327 | tortoise = SCM_CDR(tortoise); | |
df13742c | 328 | } |
bc36d050 | 329 | while (!scm_is_eq (hare, tortoise)); |
1afff620 | 330 | SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst)); |
df13742c | 331 | } |
1bbd0b84 | 332 | #undef FUNC_NAME |
df13742c JB |
333 | |
334 | \f | |
335 | /* reversing lists */ | |
0f2d19dd | 336 | |
a1ec6916 | 337 | SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, |
e1385ffc | 338 | (SCM lst), |
5352393c MG |
339 | "Return a new list that contains the elements of @var{lst} but\n" |
340 | "in reverse order.") | |
e1385ffc GB |
341 | #define FUNC_NAME s_scm_reverse |
342 | { | |
343 | SCM result = SCM_EOL; | |
344 | SCM tortoise = lst; | |
345 | SCM hare = lst; | |
346 | ||
347 | do { | |
c96d76b8 | 348 | if (SCM_NULL_OR_NIL_P(hare)) return result; |
d2e53ed6 | 349 | SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME); |
e1385ffc GB |
350 | result = scm_cons (SCM_CAR (hare), result); |
351 | hare = SCM_CDR (hare); | |
c96d76b8 | 352 | if (SCM_NULL_OR_NIL_P(hare)) return result; |
d2e53ed6 | 353 | SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME); |
e1385ffc GB |
354 | result = scm_cons (SCM_CAR (hare), result); |
355 | hare = SCM_CDR (hare); | |
356 | tortoise = SCM_CDR (tortoise); | |
357 | } | |
bc36d050 | 358 | while (!scm_is_eq (hare, tortoise)); |
1afff620 | 359 | SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst)); |
e1385ffc GB |
360 | } |
361 | #undef FUNC_NAME | |
362 | ||
363 | SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, | |
364 | (SCM lst, SCM new_tail), | |
7a095584 NJ |
365 | "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n" |
366 | "The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is\n" | |
71a89639 MV |
367 | "modified to point to the previous list element. Return the\n" |
368 | "reversed list.\n\n" | |
b380b885 MD |
369 | "Caveat: because the list is modified in place, the tail of the original\n" |
370 | "list now becomes its head, and the head of the original list now becomes\n" | |
371 | "the tail. Therefore, the @var{lst} symbol to which the head of the\n" | |
372 | "original list was bound now points to the tail. To ensure that the head\n" | |
373 | "of the modified list is not lost, it is wise to save the return value of\n" | |
374 | "@code{reverse!}") | |
1bbd0b84 | 375 | #define FUNC_NAME s_scm_reverse_x |
0f2d19dd | 376 | { |
0ece4850 DK |
377 | SCM old_lst = lst; |
378 | SCM tail = SCM_BOOL_F; | |
379 | ||
3946f0de MD |
380 | if (SCM_UNBNDP (new_tail)) |
381 | new_tail = SCM_EOL; | |
0f2d19dd | 382 | |
0ece4850 DK |
383 | if (SCM_NULL_OR_NIL_P (lst)) |
384 | return new_tail; | |
385 | ||
386 | /* SCM_VALIDATE_LIST would run through the whole list to make sure it | |
387 | is not eventually circular. In contrast to most list operations, | |
388 | reverse! cannot get stuck in an infinite loop but arrives back at | |
389 | the start when given an eventually or fully circular list. Because | |
390 | of that, we can save the cost of an upfront proper list check at | |
391 | the price of having to do a double reversal in the error case. | |
392 | */ | |
393 | ||
394 | while (scm_is_pair (lst)) | |
3946f0de | 395 | { |
e1385ffc | 396 | SCM old_tail = SCM_CDR (lst); |
0ece4850 DK |
397 | SCM_SETCDR (lst, tail); |
398 | tail = lst; | |
e1385ffc | 399 | lst = old_tail; |
3946f0de | 400 | } |
0ece4850 DK |
401 | |
402 | if (SCM_LIKELY (SCM_NULL_OR_NIL_P (lst))) | |
403 | { | |
404 | SCM_SETCDR (old_lst, new_tail); | |
405 | return tail; | |
406 | } | |
407 | ||
408 | /* We did not start with a proper list. Undo the reversal. */ | |
409 | ||
410 | while (scm_is_pair (tail)) | |
411 | { | |
412 | SCM old_tail = SCM_CDR (tail); | |
413 | SCM_SETCDR (tail, lst); | |
414 | lst = tail; | |
415 | tail = old_tail; | |
416 | } | |
417 | ||
418 | SCM_WRONG_TYPE_ARG (1, lst); | |
419 | return lst; | |
0f2d19dd | 420 | } |
1bbd0b84 | 421 | #undef FUNC_NAME |
0f2d19dd | 422 | |
0f2d19dd | 423 | \f |
685c0d71 | 424 | |
df13742c | 425 | /* indexing lists by element number */ |
0f2d19dd | 426 | |
3b3b36dd | 427 | SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, |
685c0d71 | 428 | (SCM list, SCM k), |
5352393c | 429 | "Return the @var{k}th element from @var{list}.") |
1bbd0b84 GB |
430 | #define FUNC_NAME s_scm_list_ref |
431 | { | |
685c0d71 | 432 | SCM lst = list; |
c014a02e | 433 | unsigned long int i; |
a55c2b68 | 434 | i = scm_to_ulong (k); |
d2e53ed6 | 435 | while (scm_is_pair (lst)) { |
685c0d71 DH |
436 | if (i == 0) |
437 | return SCM_CAR (lst); | |
438 | else { | |
439 | --i; | |
440 | lst = SCM_CDR (lst); | |
441 | } | |
442 | }; | |
c96d76b8 | 443 | if (SCM_NULL_OR_NIL_P (lst)) |
685c0d71 DH |
444 | SCM_OUT_OF_RANGE (2, k); |
445 | else | |
446 | SCM_WRONG_TYPE_ARG (1, list); | |
0f2d19dd | 447 | } |
1bbd0b84 | 448 | #undef FUNC_NAME |
0f2d19dd | 449 | |
685c0d71 | 450 | |
3b3b36dd | 451 | SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, |
685c0d71 DH |
452 | (SCM list, SCM k, SCM val), |
453 | "Set the @var{k}th element of @var{list} to @var{val}.") | |
1bbd0b84 GB |
454 | #define FUNC_NAME s_scm_list_set_x |
455 | { | |
685c0d71 | 456 | SCM lst = list; |
a55c2b68 | 457 | unsigned long int i = scm_to_ulong (k); |
d2e53ed6 | 458 | while (scm_is_pair (lst)) { |
685c0d71 DH |
459 | if (i == 0) { |
460 | SCM_SETCAR (lst, val); | |
461 | return val; | |
462 | } else { | |
463 | --i; | |
464 | lst = SCM_CDR (lst); | |
465 | } | |
466 | }; | |
c96d76b8 | 467 | if (SCM_NULL_OR_NIL_P (lst)) |
685c0d71 DH |
468 | SCM_OUT_OF_RANGE (2, k); |
469 | else | |
470 | SCM_WRONG_TYPE_ARG (1, list); | |
0f2d19dd | 471 | } |
1bbd0b84 | 472 | #undef FUNC_NAME |
0f2d19dd JB |
473 | |
474 | ||
1bbd0b84 GB |
475 | SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail); |
476 | ||
3b3b36dd | 477 | SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0, |
1bbd0b84 | 478 | (SCM lst, SCM k), |
8f85c0c6 | 479 | "@deffnx {Scheme Procedure} list-cdr-ref lst k\n" |
b380b885 MD |
480 | "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n" |
481 | "The first element of the list is considered to be element 0.\n\n" | |
872e0c72 | 482 | "@code{list-tail} and @code{list-cdr-ref} are identical. It may help to\n" |
b380b885 MD |
483 | "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n" |
484 | "or returning the results of cdring @var{k} times down @var{lst}.") | |
1bbd0b84 | 485 | #define FUNC_NAME s_scm_list_tail |
df13742c | 486 | { |
a55c2b68 | 487 | size_t i = scm_to_size_t (k); |
df13742c | 488 | while (i-- > 0) { |
34d19ef6 | 489 | SCM_VALIDATE_CONS (1, lst); |
df13742c JB |
490 | lst = SCM_CDR(lst); |
491 | } | |
492 | return lst; | |
493 | } | |
1bbd0b84 | 494 | #undef FUNC_NAME |
df13742c | 495 | |
0f2d19dd | 496 | |
3b3b36dd | 497 | SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, |
685c0d71 DH |
498 | (SCM list, SCM k, SCM val), |
499 | "Set the @var{k}th cdr of @var{list} to @var{val}.") | |
1bbd0b84 GB |
500 | #define FUNC_NAME s_scm_list_cdr_set_x |
501 | { | |
685c0d71 | 502 | SCM lst = list; |
a55c2b68 | 503 | size_t i = scm_to_size_t (k); |
d2e53ed6 | 504 | while (scm_is_pair (lst)) { |
685c0d71 DH |
505 | if (i == 0) { |
506 | SCM_SETCDR (lst, val); | |
507 | return val; | |
508 | } else { | |
509 | --i; | |
510 | lst = SCM_CDR (lst); | |
511 | } | |
512 | }; | |
c96d76b8 | 513 | if (SCM_NULL_OR_NIL_P (lst)) |
685c0d71 DH |
514 | SCM_OUT_OF_RANGE (2, k); |
515 | else | |
516 | SCM_WRONG_TYPE_ARG (1, list); | |
0f2d19dd | 517 | } |
1bbd0b84 | 518 | #undef FUNC_NAME |
0f2d19dd JB |
519 | |
520 | ||
521 | \f | |
df13742c | 522 | /* copying lists, perhaps partially */ |
0f2d19dd | 523 | |
3b3b36dd | 524 | SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0, |
1bbd0b84 | 525 | (SCM lst, SCM k), |
b380b885 MD |
526 | "Copy the first @var{k} elements from @var{lst} into a new list, and\n" |
527 | "return it.") | |
1bbd0b84 | 528 | #define FUNC_NAME s_scm_list_head |
0f2d19dd JB |
529 | { |
530 | SCM answer; | |
531 | SCM * pos; | |
a55c2b68 | 532 | size_t i = scm_to_size_t (k); |
0f2d19dd | 533 | |
0f2d19dd JB |
534 | answer = SCM_EOL; |
535 | pos = &answer; | |
0f2d19dd JB |
536 | while (i-- > 0) |
537 | { | |
34d19ef6 | 538 | SCM_VALIDATE_CONS (1, lst); |
0f2d19dd | 539 | *pos = scm_cons (SCM_CAR (lst), SCM_EOL); |
25d8012c | 540 | pos = SCM_CDRLOC (*pos); |
0f2d19dd JB |
541 | lst = SCM_CDR(lst); |
542 | } | |
543 | return answer; | |
544 | } | |
1bbd0b84 | 545 | #undef FUNC_NAME |
0f2d19dd JB |
546 | |
547 | ||
212e58ed DH |
548 | /* Copy a list which is known to be finite. The last pair may or may not have |
549 | * a '() in its cdr. That is, improper lists are accepted. */ | |
550 | SCM | |
551 | scm_i_finite_list_copy (SCM list) | |
552 | { | |
d2e53ed6 | 553 | if (!scm_is_pair (list)) |
212e58ed DH |
554 | { |
555 | return list; | |
556 | } | |
557 | else | |
558 | { | |
559 | SCM tail; | |
560 | const SCM result = tail = scm_list_1 (SCM_CAR (list)); | |
561 | list = SCM_CDR (list); | |
d2e53ed6 | 562 | while (scm_is_pair (list)) |
212e58ed DH |
563 | { |
564 | const SCM new_tail = scm_list_1 (SCM_CAR (list)); | |
565 | SCM_SETCDR (tail, new_tail); | |
566 | tail = new_tail; | |
567 | list = SCM_CDR (list); | |
568 | } | |
569 | SCM_SETCDR (tail, list); | |
570 | ||
571 | return result; | |
572 | } | |
573 | } | |
574 | ||
575 | ||
a1ec6916 | 576 | SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, |
1bbd0b84 | 577 | (SCM lst), |
b380b885 | 578 | "Return a (newly-created) copy of @var{lst}.") |
1bbd0b84 | 579 | #define FUNC_NAME s_scm_list_copy |
df13742c JB |
580 | { |
581 | SCM newlst; | |
582 | SCM * fill_here; | |
583 | SCM from_here; | |
584 | ||
5d6bb349 KN |
585 | SCM_VALIDATE_LIST (1, lst); |
586 | ||
df13742c JB |
587 | newlst = SCM_EOL; |
588 | fill_here = &newlst; | |
589 | from_here = lst; | |
590 | ||
d2e53ed6 | 591 | while (scm_is_pair (from_here)) |
df13742c JB |
592 | { |
593 | SCM c; | |
594 | c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here)); | |
595 | *fill_here = c; | |
25d8012c | 596 | fill_here = SCM_CDRLOC (c); |
df13742c JB |
597 | from_here = SCM_CDR (from_here); |
598 | } | |
599 | return newlst; | |
600 | } | |
1bbd0b84 | 601 | #undef FUNC_NAME |
df13742c | 602 | |
fad3aaf1 KR |
603 | |
604 | SCM_PROC (s_list, "list", 0, 0, 1, scm_list_copy); | |
123a1b62 | 605 | SCM_SNARF_DOCS (primitive, scm_list_copy, "list", (SCM objs), 0, 0, 1, |
fad3aaf1 KR |
606 | "Return a list containing @var{objs}, the arguments to\n" |
607 | "@code{list}.") | |
608 | ||
303bddc8 KR |
609 | /* This used to be the code for "list", but it's wrong when used via apply |
610 | (it should copy the list). It seems pretty unlikely anyone would have | |
611 | been using this from C code, since it's a no-op, but keep it for strict | |
612 | binary compatibility. */ | |
613 | SCM | |
614 | scm_list (SCM objs) | |
615 | { | |
616 | return objs; | |
617 | } | |
618 | ||
fad3aaf1 | 619 | |
0f2d19dd | 620 | \f |
df13742c JB |
621 | /* membership tests (memq, memv, etc.) */ |
622 | ||
79a3dafe DH |
623 | /* The function scm_c_memq returns the first sublist of list whose car is |
624 | * 'eq?' obj, where the sublists of list are the non-empty lists returned by | |
625 | * (list-tail list k) for k less than the length of list. If obj does not | |
1e6808ea | 626 | * occur in list, then #f (not the empty list) is returned. |
79a3dafe DH |
627 | * List must be a proper list, otherwise scm_c_memq may crash or loop |
628 | * endlessly. | |
629 | */ | |
630 | SCM | |
631 | scm_c_memq (SCM obj, SCM list) | |
632 | { | |
c96d76b8 | 633 | for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list)) |
79a3dafe | 634 | { |
bc36d050 | 635 | if (scm_is_eq (SCM_CAR (list), obj)) |
79a3dafe DH |
636 | return list; |
637 | } | |
638 | return SCM_BOOL_F; | |
639 | } | |
640 | ||
641 | ||
3b3b36dd | 642 | SCM_DEFINE (scm_memq, "memq", 2, 0, 0, |
1bbd0b84 | 643 | (SCM x, SCM lst), |
5352393c MG |
644 | "Return the first sublist of @var{lst} whose car is @code{eq?}\n" |
645 | "to @var{x} where the sublists of @var{lst} are the non-empty\n" | |
646 | "lists returned by @code{(list-tail @var{lst} @var{k})} for\n" | |
647 | "@var{k} less than the length of @var{lst}. If @var{x} does not\n" | |
648 | "occur in @var{lst}, then @code{#f} (not the empty list) is\n" | |
649 | "returned.") | |
1bbd0b84 | 650 | #define FUNC_NAME s_scm_memq |
0f2d19dd | 651 | { |
3b7f4ba3 AW |
652 | SCM hare = lst, tortoise = lst; |
653 | ||
654 | while (scm_is_pair (hare)) | |
655 | { | |
656 | if (scm_is_eq (SCM_CAR (hare), x)) | |
657 | return hare; | |
658 | else | |
659 | hare = SCM_CDR (hare); | |
660 | ||
661 | if (!scm_is_pair (hare)) | |
662 | break; | |
663 | ||
664 | if (scm_is_eq (SCM_CAR (hare), x)) | |
665 | return hare; | |
666 | else | |
667 | hare = SCM_CDR (hare); | |
668 | ||
669 | tortoise = SCM_CDR (tortoise); | |
670 | if (SCM_UNLIKELY (scm_is_eq (hare, tortoise))) | |
671 | break; | |
672 | } | |
673 | ||
674 | if (SCM_LIKELY (scm_is_null (hare))) | |
675 | return SCM_BOOL_F; | |
676 | else | |
677 | scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list"); | |
0f2d19dd | 678 | } |
1bbd0b84 | 679 | #undef FUNC_NAME |
0f2d19dd JB |
680 | |
681 | ||
3b3b36dd | 682 | SCM_DEFINE (scm_memv, "memv", 2, 0, 0, |
1bbd0b84 | 683 | (SCM x, SCM lst), |
5352393c MG |
684 | "Return the first sublist of @var{lst} whose car is @code{eqv?}\n" |
685 | "to @var{x} where the sublists of @var{lst} are the non-empty\n" | |
686 | "lists returned by @code{(list-tail @var{lst} @var{k})} for\n" | |
687 | "@var{k} less than the length of @var{lst}. If @var{x} does not\n" | |
688 | "occur in @var{lst}, then @code{#f} (not the empty list) is\n" | |
689 | "returned.") | |
1bbd0b84 | 690 | #define FUNC_NAME s_scm_memv |
0f2d19dd | 691 | { |
3b7f4ba3 AW |
692 | SCM hare = lst, tortoise = lst; |
693 | ||
694 | while (scm_is_pair (hare)) | |
daa6ba18 | 695 | { |
3b7f4ba3 AW |
696 | if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x))) |
697 | return hare; | |
698 | else | |
699 | hare = SCM_CDR (hare); | |
700 | ||
701 | if (!scm_is_pair (hare)) | |
702 | break; | |
703 | ||
704 | if (scm_is_true (scm_eqv_p (SCM_CAR (hare), x))) | |
705 | return hare; | |
706 | else | |
707 | hare = SCM_CDR (hare); | |
708 | ||
709 | tortoise = SCM_CDR (tortoise); | |
710 | if (SCM_UNLIKELY (scm_is_eq (hare, tortoise))) | |
711 | break; | |
daa6ba18 | 712 | } |
3b7f4ba3 AW |
713 | |
714 | if (SCM_LIKELY (scm_is_null (hare))) | |
715 | return SCM_BOOL_F; | |
716 | else | |
717 | scm_wrong_type_arg_msg (FUNC_NAME, 2, lst, "list"); | |
0f2d19dd | 718 | } |
1bbd0b84 | 719 | #undef FUNC_NAME |
0f2d19dd JB |
720 | |
721 | ||
3b3b36dd | 722 | SCM_DEFINE (scm_member, "member", 2, 0, 0, |
1bbd0b84 | 723 | (SCM x, SCM lst), |
5352393c MG |
724 | "Return the first sublist of @var{lst} whose car is\n" |
725 | "@code{equal?} to @var{x} where the sublists of @var{lst} are\n" | |
726 | "the non-empty lists returned by @code{(list-tail @var{lst}\n" | |
727 | "@var{k})} for @var{k} less than the length of @var{lst}. If\n" | |
728 | "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n" | |
729 | "empty list) is returned.") | |
1bbd0b84 | 730 | #define FUNC_NAME s_scm_member |
0f2d19dd | 731 | { |
daa6ba18 | 732 | SCM_VALIDATE_LIST (2, lst); |
c96d76b8 | 733 | for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst)) |
daa6ba18 | 734 | { |
7888309b | 735 | if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x))) |
daa6ba18 DH |
736 | return lst; |
737 | } | |
738 | return SCM_BOOL_F; | |
0f2d19dd | 739 | } |
1bbd0b84 | 740 | #undef FUNC_NAME |
0f2d19dd | 741 | |
0f2d19dd | 742 | \f |
df13742c | 743 | /* deleting elements from a list (delq, etc.) */ |
0f2d19dd | 744 | |
3b3b36dd | 745 | SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0, |
1bbd0b84 | 746 | (SCM item, SCM lst), |
8f85c0c6 NJ |
747 | "@deffnx {Scheme Procedure} delv! item lst\n" |
748 | "@deffnx {Scheme Procedure} delete! item lst\n" | |
b380b885 | 749 | "These procedures are destructive versions of @code{delq}, @code{delv}\n" |
bfefbf18 | 750 | "and @code{delete}: they modify the existing @var{lst}\n" |
b380b885 MD |
751 | "rather than creating a new list. Caveat evaluator: Like other\n" |
752 | "destructive list functions, these functions cannot modify the binding of\n" | |
753 | "@var{lst}, and so cannot be used to delete the first element of\n" | |
754 | "@var{lst} destructively.") | |
1bbd0b84 | 755 | #define FUNC_NAME s_scm_delq_x |
0f2d19dd | 756 | { |
164271a1 JB |
757 | SCM walk; |
758 | SCM *prev; | |
0f2d19dd | 759 | |
164271a1 | 760 | for (prev = &lst, walk = lst; |
d2e53ed6 | 761 | scm_is_pair (walk); |
164271a1 | 762 | walk = SCM_CDR (walk)) |
0f2d19dd | 763 | { |
bc36d050 | 764 | if (scm_is_eq (SCM_CAR (walk), item)) |
164271a1 JB |
765 | *prev = SCM_CDR (walk); |
766 | else | |
767 | prev = SCM_CDRLOC (walk); | |
0f2d19dd | 768 | } |
164271a1 JB |
769 | |
770 | return lst; | |
0f2d19dd | 771 | } |
1bbd0b84 | 772 | #undef FUNC_NAME |
0f2d19dd JB |
773 | |
774 | ||
3b3b36dd | 775 | SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0, |
5352393c MG |
776 | (SCM item, SCM lst), |
777 | "Destructively remove all elements from @var{lst} that are\n" | |
778 | "@code{eqv?} to @var{item}.") | |
1bbd0b84 | 779 | #define FUNC_NAME s_scm_delv_x |
0f2d19dd | 780 | { |
164271a1 JB |
781 | SCM walk; |
782 | SCM *prev; | |
0f2d19dd | 783 | |
164271a1 | 784 | for (prev = &lst, walk = lst; |
d2e53ed6 | 785 | scm_is_pair (walk); |
164271a1 | 786 | walk = SCM_CDR (walk)) |
0f2d19dd | 787 | { |
7888309b | 788 | if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item))) |
164271a1 JB |
789 | *prev = SCM_CDR (walk); |
790 | else | |
791 | prev = SCM_CDRLOC (walk); | |
0f2d19dd | 792 | } |
164271a1 JB |
793 | |
794 | return lst; | |
0f2d19dd | 795 | } |
1bbd0b84 | 796 | #undef FUNC_NAME |
0f2d19dd JB |
797 | |
798 | ||
799 | ||
3b3b36dd | 800 | SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0, |
5352393c MG |
801 | (SCM item, SCM lst), |
802 | "Destructively remove all elements from @var{lst} that are\n" | |
803 | "@code{equal?} to @var{item}.") | |
1bbd0b84 | 804 | #define FUNC_NAME s_scm_delete_x |
0f2d19dd | 805 | { |
164271a1 JB |
806 | SCM walk; |
807 | SCM *prev; | |
0f2d19dd | 808 | |
164271a1 | 809 | for (prev = &lst, walk = lst; |
d2e53ed6 | 810 | scm_is_pair (walk); |
164271a1 | 811 | walk = SCM_CDR (walk)) |
0f2d19dd | 812 | { |
7888309b | 813 | if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item))) |
164271a1 JB |
814 | *prev = SCM_CDR (walk); |
815 | else | |
816 | prev = SCM_CDRLOC (walk); | |
0f2d19dd | 817 | } |
164271a1 JB |
818 | |
819 | return lst; | |
0f2d19dd | 820 | } |
1bbd0b84 | 821 | #undef FUNC_NAME |
0f2d19dd JB |
822 | |
823 | ||
824 | \f | |
825 | ||
0f2d19dd | 826 | |
a1ec6916 | 827 | SCM_DEFINE (scm_delq, "delq", 2, 0, 0, |
1bbd0b84 | 828 | (SCM item, SCM lst), |
5352393c MG |
829 | "Return a newly-created copy of @var{lst} with elements\n" |
830 | "@code{eq?} to @var{item} removed. This procedure mirrors\n" | |
831 | "@code{memq}: @code{delq} compares elements of @var{lst} against\n" | |
832 | "@var{item} with @code{eq?}.") | |
1bbd0b84 | 833 | #define FUNC_NAME s_scm_delq |
0f2d19dd | 834 | { |
1bbd0b84 | 835 | SCM copy = scm_list_copy (lst); |
0f2d19dd JB |
836 | return scm_delq_x (item, copy); |
837 | } | |
1bbd0b84 | 838 | #undef FUNC_NAME |
0f2d19dd | 839 | |
a1ec6916 | 840 | SCM_DEFINE (scm_delv, "delv", 2, 0, 0, |
1bbd0b84 | 841 | (SCM item, SCM lst), |
5352393c MG |
842 | "Return a newly-created copy of @var{lst} with elements\n" |
843 | "@code{eqv?} to @var{item} removed. This procedure mirrors\n" | |
844 | "@code{memv}: @code{delv} compares elements of @var{lst} against\n" | |
845 | "@var{item} with @code{eqv?}.") | |
1bbd0b84 | 846 | #define FUNC_NAME s_scm_delv |
0f2d19dd | 847 | { |
1bbd0b84 | 848 | SCM copy = scm_list_copy (lst); |
0f2d19dd JB |
849 | return scm_delv_x (item, copy); |
850 | } | |
1bbd0b84 | 851 | #undef FUNC_NAME |
0f2d19dd | 852 | |
a1ec6916 | 853 | SCM_DEFINE (scm_delete, "delete", 2, 0, 0, |
1bbd0b84 | 854 | (SCM item, SCM lst), |
5352393c MG |
855 | "Return a newly-created copy of @var{lst} with elements\n" |
856 | "@code{equal?} to @var{item} removed. This procedure mirrors\n" | |
857 | "@code{member}: @code{delete} compares elements of @var{lst}\n" | |
858 | "against @var{item} with @code{equal?}.") | |
1bbd0b84 | 859 | #define FUNC_NAME s_scm_delete |
0f2d19dd | 860 | { |
1bbd0b84 | 861 | SCM copy = scm_list_copy (lst); |
0f2d19dd JB |
862 | return scm_delete_x (item, copy); |
863 | } | |
1bbd0b84 | 864 | #undef FUNC_NAME |
0f2d19dd JB |
865 | |
866 | ||
3b3b36dd | 867 | SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0, |
1bbd0b84 | 868 | (SCM item, SCM lst), |
5352393c MG |
869 | "Like @code{delq!}, but only deletes the first occurrence of\n" |
870 | "@var{item} from @var{lst}. Tests for equality using\n" | |
871 | "@code{eq?}. See also @code{delv1!} and @code{delete1!}.") | |
1bbd0b84 | 872 | #define FUNC_NAME s_scm_delq1_x |
82dc9f57 MD |
873 | { |
874 | SCM walk; | |
875 | SCM *prev; | |
876 | ||
877 | for (prev = &lst, walk = lst; | |
d2e53ed6 | 878 | scm_is_pair (walk); |
82dc9f57 MD |
879 | walk = SCM_CDR (walk)) |
880 | { | |
bc36d050 | 881 | if (scm_is_eq (SCM_CAR (walk), item)) |
82dc9f57 MD |
882 | { |
883 | *prev = SCM_CDR (walk); | |
884 | break; | |
885 | } | |
886 | else | |
887 | prev = SCM_CDRLOC (walk); | |
888 | } | |
889 | ||
890 | return lst; | |
891 | } | |
1bbd0b84 | 892 | #undef FUNC_NAME |
82dc9f57 MD |
893 | |
894 | ||
3b3b36dd | 895 | SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0, |
8507b88c | 896 | (SCM item, SCM lst), |
5352393c MG |
897 | "Like @code{delv!}, but only deletes the first occurrence of\n" |
898 | "@var{item} from @var{lst}. Tests for equality using\n" | |
899 | "@code{eqv?}. See also @code{delq1!} and @code{delete1!}.") | |
1bbd0b84 | 900 | #define FUNC_NAME s_scm_delv1_x |
82dc9f57 MD |
901 | { |
902 | SCM walk; | |
903 | SCM *prev; | |
904 | ||
905 | for (prev = &lst, walk = lst; | |
d2e53ed6 | 906 | scm_is_pair (walk); |
82dc9f57 MD |
907 | walk = SCM_CDR (walk)) |
908 | { | |
7888309b | 909 | if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item))) |
82dc9f57 MD |
910 | { |
911 | *prev = SCM_CDR (walk); | |
912 | break; | |
913 | } | |
914 | else | |
915 | prev = SCM_CDRLOC (walk); | |
916 | } | |
917 | ||
918 | return lst; | |
919 | } | |
1bbd0b84 | 920 | #undef FUNC_NAME |
82dc9f57 MD |
921 | |
922 | ||
3b3b36dd | 923 | SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0, |
8507b88c | 924 | (SCM item, SCM lst), |
5352393c MG |
925 | "Like @code{delete!}, but only deletes the first occurrence of\n" |
926 | "@var{item} from @var{lst}. Tests for equality using\n" | |
927 | "@code{equal?}. See also @code{delq1!} and @code{delv1!}.") | |
1bbd0b84 | 928 | #define FUNC_NAME s_scm_delete1_x |
82dc9f57 MD |
929 | { |
930 | SCM walk; | |
931 | SCM *prev; | |
932 | ||
933 | for (prev = &lst, walk = lst; | |
d2e53ed6 | 934 | scm_is_pair (walk); |
82dc9f57 MD |
935 | walk = SCM_CDR (walk)) |
936 | { | |
7888309b | 937 | if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item))) |
82dc9f57 MD |
938 | { |
939 | *prev = SCM_CDR (walk); | |
940 | break; | |
941 | } | |
942 | else | |
943 | prev = SCM_CDRLOC (walk); | |
944 | } | |
945 | ||
946 | return lst; | |
947 | } | |
1bbd0b84 | 948 | #undef FUNC_NAME |
82dc9f57 | 949 | |
c614a00b MD |
950 | SCM_DEFINE (scm_filter, "filter", 2, 0, 0, |
951 | (SCM pred, SCM list), | |
952 | "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n" | |
953 | "The list is not disordered -- elements that appear in the result list occur\n" | |
954 | "in the same order as they occur in the argument list. The returned list may\n" | |
955 | "share a common tail with the argument list. The dynamic order in which the\n" | |
956 | "various applications of pred are made is not specified.\n\n" | |
957 | "@lisp\n" | |
958 | "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n" | |
959 | "@end lisp") | |
960 | #define FUNC_NAME s_scm_filter | |
961 | { | |
c614a00b MD |
962 | SCM walk; |
963 | SCM *prev; | |
964 | SCM res = SCM_EOL; | |
6c9e8a53 | 965 | SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME); |
c614a00b MD |
966 | SCM_VALIDATE_LIST (2, list); |
967 | ||
968 | for (prev = &res, walk = list; | |
d2e53ed6 | 969 | scm_is_pair (walk); |
c614a00b MD |
970 | walk = SCM_CDR (walk)) |
971 | { | |
6c9e8a53 | 972 | if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk)))) |
c614a00b MD |
973 | { |
974 | *prev = scm_cons (SCM_CAR (walk), SCM_EOL); | |
975 | prev = SCM_CDRLOC (*prev); | |
976 | } | |
977 | } | |
978 | ||
979 | return res; | |
980 | } | |
981 | #undef FUNC_NAME | |
982 | ||
983 | SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0, | |
984 | (SCM pred, SCM list), | |
985 | "Linear-update variant of @code{filter}.") | |
986 | #define FUNC_NAME s_scm_filter_x | |
987 | { | |
c614a00b MD |
988 | SCM walk; |
989 | SCM *prev; | |
6c9e8a53 | 990 | SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME); |
c614a00b MD |
991 | SCM_VALIDATE_LIST (2, list); |
992 | ||
993 | for (prev = &list, walk = list; | |
d2e53ed6 | 994 | scm_is_pair (walk); |
c614a00b MD |
995 | walk = SCM_CDR (walk)) |
996 | { | |
6c9e8a53 | 997 | if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk)))) |
c614a00b MD |
998 | prev = SCM_CDRLOC (walk); |
999 | else | |
1000 | *prev = SCM_CDR (walk); | |
1001 | } | |
1002 | ||
1003 | return list; | |
1004 | } | |
1005 | #undef FUNC_NAME | |
82dc9f57 | 1006 | |
0f2d19dd | 1007 | \f |
0f2d19dd JB |
1008 | void |
1009 | scm_init_list () | |
0f2d19dd | 1010 | { |
a0599745 | 1011 | #include "libguile/list.x" |
0f2d19dd | 1012 | } |
89e00824 ML |
1013 | |
1014 | /* | |
1015 | Local Variables: | |
1016 | c-file-style: "gnu" | |
1017 | End: | |
1018 | */ |