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