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