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