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