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