Commit | Line | Data |
---|---|---|
ee6aac97 MD |
1 | /* srfi-1.c --- SRFI-1 procedures for Guile |
2 | * | |
2d5ef309 LC |
3 | * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, |
4 | * 2008, 2009, 2010, 2011 Free Software Foundation, Inc. | |
cf9d3c47 | 5 | * |
73be1d9e | 6 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
7 | * modify it under the terms of the GNU Lesser General Public License |
8 | * as published by the Free Software Foundation; either version 3 of | |
9 | * the License, or (at your option) any later version. | |
ee6aac97 | 10 | * |
53befeb7 NJ |
11 | * This library is distributed in the hope that it will be useful, but |
12 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | * Lesser General Public License for more details. | |
ee6aac97 | 15 | * |
73be1d9e MV |
16 | * You should have received a copy of the GNU Lesser General Public |
17 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
18 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
19 | * 02110-1301 USA | |
73be1d9e | 20 | */ |
ee6aac97 | 21 | |
37710f7e | 22 | \f |
dbb605f5 | 23 | #ifdef HAVE_CONFIG_H |
a030cb4b LC |
24 | # include <config.h> |
25 | #endif | |
26 | ||
37710f7e AW |
27 | #include "libguile/_scm.h" |
28 | #include "libguile/eq.h" | |
29 | ||
30 | #include "libguile/validate.h" | |
31 | #include "libguile/list.h" | |
32 | #include "libguile/eval.h" | |
33 | #include "libguile/srfi-1.h" | |
34 | ||
35 | #include <stdarg.h> | |
ee6aac97 | 36 | |
ee6aac97 | 37 | |
0b7f2eb8 LC |
38 | /* The intent of this file was to gradually replace those Scheme |
39 | * procedures in srfi-1.scm that extend core primitive procedures, | |
37710f7e | 40 | * so that using srfi-1 wouldn't have performance penalties. |
ee6aac97 | 41 | * |
0b7f2eb8 LC |
42 | * However, we now prefer to write these procedures in Scheme, let the compiler |
43 | * optimize them, and have the VM execute them efficiently. | |
ee6aac97 MD |
44 | */ |
45 | ||
0b7f2eb8 | 46 | |
d0a634de KR |
47 | static SCM |
48 | equal_trampoline (SCM proc, SCM arg1, SCM arg2) | |
49 | { | |
50 | return scm_equal_p (arg1, arg2); | |
51 | } | |
52 | ||
cf9d3c47 KR |
53 | /* list_copy_part() copies the first COUNT cells of LST, puts the result at |
54 | *dst, and returns the SCM_CDRLOC of the last cell in that new list. | |
55 | ||
56 | This function is designed to be careful about LST possibly having changed | |
57 | in between the caller deciding what to copy, and the copy actually being | |
58 | done here. The COUNT ensures we terminate if LST has become circular, | |
59 | SCM_VALIDATE_CONS guards against a cdr in the list changed to some | |
60 | non-pair object. */ | |
61 | ||
62 | #include <stdio.h> | |
63 | static SCM * | |
64 | list_copy_part (SCM lst, int count, SCM *dst) | |
65 | #define FUNC_NAME "list_copy_part" | |
66 | { | |
67 | SCM c; | |
68 | for ( ; count > 0; count--) | |
69 | { | |
70 | SCM_VALIDATE_CONS (SCM_ARGn, lst); | |
71 | c = scm_cons (SCM_CAR (lst), SCM_EOL); | |
72 | *dst = c; | |
73 | dst = SCM_CDRLOC (c); | |
74 | lst = SCM_CDR (lst); | |
75 | } | |
76 | return dst; | |
77 | } | |
78 | #undef FUNC_NAME | |
79 | ||
d0a634de | 80 | |
9a993171 KR |
81 | SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0, |
82 | (SCM revhead, SCM tail), | |
83 | "Reverse @var{rev-head}, append @var{tail} to it, and return the\n" | |
84 | "result. This is equivalent to @code{(append (reverse\n" | |
85 | "@var{rev-head}) @var{tail})}, but its implementation is more\n" | |
86 | "efficient.\n" | |
87 | "\n" | |
88 | "@example\n" | |
89 | "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n" | |
90 | "@end example") | |
91 | #define FUNC_NAME s_scm_srfi1_append_reverse | |
92 | { | |
93 | while (scm_is_pair (revhead)) | |
94 | { | |
95 | /* copy first element of revhead onto front of tail */ | |
96 | tail = scm_cons (SCM_CAR (revhead), tail); | |
97 | revhead = SCM_CDR (revhead); | |
98 | } | |
99 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME, | |
100 | "list"); | |
101 | return tail; | |
102 | } | |
103 | #undef FUNC_NAME | |
104 | ||
105 | ||
106 | SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0, | |
107 | (SCM revhead, SCM tail), | |
108 | "Reverse @var{rev-head}, append @var{tail} to it, and return the\n" | |
109 | "result. This is equivalent to @code{(append! (reverse!\n" | |
110 | "@var{rev-head}) @var{tail})}, but its implementation is more\n" | |
111 | "efficient.\n" | |
112 | "\n" | |
113 | "@example\n" | |
114 | "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n" | |
115 | "@end example\n" | |
116 | "\n" | |
117 | "@var{rev-head} may be modified in order to produce the result.") | |
118 | #define FUNC_NAME s_scm_srfi1_append_reverse_x | |
119 | { | |
120 | SCM newtail; | |
121 | ||
122 | while (scm_is_pair (revhead)) | |
123 | { | |
124 | /* take the first cons cell from revhead */ | |
125 | newtail = revhead; | |
126 | revhead = SCM_CDR (revhead); | |
127 | ||
128 | /* make it the new start of tail, appending the previous */ | |
129 | SCM_SETCDR (newtail, tail); | |
130 | tail = newtail; | |
131 | } | |
132 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME, | |
133 | "list"); | |
134 | return tail; | |
135 | } | |
136 | #undef FUNC_NAME | |
137 | ||
c66c6d53 KR |
138 | SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0, |
139 | (SCM lstlst), | |
140 | "Construct a list by appending all lists in @var{lstlst}.\n" | |
141 | "\n" | |
142 | "@code{concatenate} is the same as @code{(apply append\n" | |
143 | "@var{lstlst})}. It exists because some Scheme implementations\n" | |
144 | "have a limit on the number of arguments a function takes, which\n" | |
145 | "the @code{apply} might exceed. In Guile there is no such\n" | |
146 | "limit.") | |
147 | #define FUNC_NAME s_scm_srfi1_concatenate | |
148 | { | |
149 | SCM_VALIDATE_LIST (SCM_ARG1, lstlst); | |
150 | return scm_append (lstlst); | |
151 | } | |
152 | #undef FUNC_NAME | |
153 | ||
47f2726f | 154 | |
c66c6d53 KR |
155 | SCM_DEFINE (scm_srfi1_concatenate_x, "concatenate!", 1, 0, 0, |
156 | (SCM lstlst), | |
157 | "Construct a list by appending all lists in @var{lstlst}. Those\n" | |
158 | "lists may be modified to produce the result.\n" | |
159 | "\n" | |
160 | "@code{concatenate!} is the same as @code{(apply append!\n" | |
161 | "@var{lstlst})}. It exists because some Scheme implementations\n" | |
162 | "have a limit on the number of arguments a function takes, which\n" | |
163 | "the @code{apply} might exceed. In Guile there is no such\n" | |
164 | "limit.") | |
2d5ef309 | 165 | #define FUNC_NAME s_scm_srfi1_concatenate_x |
c66c6d53 KR |
166 | { |
167 | SCM_VALIDATE_LIST (SCM_ARG1, lstlst); | |
168 | return scm_append_x (lstlst); | |
169 | } | |
170 | #undef FUNC_NAME | |
47f2726f KR |
171 | |
172 | ||
110348ae | 173 | SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1, |
edea856c | 174 | (SCM pred, SCM list1, SCM rest), |
110348ae KR |
175 | "Return a count of the number of times @var{pred} returns true\n" |
176 | "when called on elements from the given lists.\n" | |
177 | "\n" | |
178 | "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n" | |
179 | "@var{elem1} @dots{} @var{elemN})}, each element being from the\n" | |
edea856c | 180 | "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n" |
110348ae KR |
181 | "with the first element of each list, the second with the second\n" |
182 | "element from each, and so on.\n" | |
183 | "\n" | |
184 | "Counting stops when the end of the shortest list is reached.\n" | |
185 | "At least one list must be non-circular.") | |
186 | #define FUNC_NAME s_scm_srfi1_count | |
187 | { | |
188 | long count; | |
5fc743b4 KR |
189 | SCM lst; |
190 | int argnum; | |
110348ae KR |
191 | SCM_VALIDATE_REST_ARGUMENT (rest); |
192 | ||
193 | count = 0; | |
194 | ||
896df2d5 | 195 | if (scm_is_null (rest)) |
110348ae KR |
196 | { |
197 | /* one list */ | |
a3e92377 | 198 | SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME); |
110348ae | 199 | |
896df2d5 | 200 | for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1)) |
a3e92377 | 201 | count += scm_is_true (scm_call_1 (pred, SCM_CAR (list1))); |
110348ae | 202 | |
5fc743b4 KR |
203 | /* check below that list1 is a proper list, and done */ |
204 | end_list1: | |
205 | lst = list1; | |
206 | argnum = 2; | |
110348ae | 207 | } |
896df2d5 | 208 | else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest))) |
110348ae KR |
209 | { |
210 | /* two lists */ | |
edea856c | 211 | SCM list2; |
110348ae | 212 | |
a3e92377 | 213 | SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME); |
110348ae | 214 | |
edea856c | 215 | list2 = SCM_CAR (rest); |
110348ae KR |
216 | for (;;) |
217 | { | |
896df2d5 | 218 | if (! scm_is_pair (list1)) |
5fc743b4 | 219 | goto end_list1; |
896df2d5 | 220 | if (! scm_is_pair (list2)) |
110348ae | 221 | { |
5fc743b4 KR |
222 | lst = list2; |
223 | argnum = 3; | |
110348ae KR |
224 | break; |
225 | } | |
a3e92377 | 226 | count += scm_is_true (scm_call_2 |
edea856c SJ |
227 | (pred, SCM_CAR (list1), SCM_CAR (list2))); |
228 | list1 = SCM_CDR (list1); | |
229 | list2 = SCM_CDR (list2); | |
110348ae KR |
230 | } |
231 | } | |
232 | else | |
233 | { | |
234 | /* three or more lists */ | |
eccd308a KR |
235 | SCM vec, args, a; |
236 | size_t len, i; | |
110348ae | 237 | |
eccd308a KR |
238 | /* vec is the list arguments */ |
239 | vec = scm_vector (scm_cons (list1, rest)); | |
240 | len = SCM_SIMPLE_VECTOR_LENGTH (vec); | |
110348ae | 241 | |
eccd308a | 242 | /* args is the argument list to pass to pred, same length as vec, |
110348ae | 243 | re-used for each call */ |
eccd308a | 244 | args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED); |
110348ae KR |
245 | |
246 | for (;;) | |
247 | { | |
eccd308a KR |
248 | /* first elem of each list in vec into args, and step those |
249 | vec entries onto their next element */ | |
250 | for (i = 0, a = args, argnum = 2; | |
251 | i < len; | |
252 | i++, a = SCM_CDR (a), argnum++) | |
110348ae | 253 | { |
eccd308a | 254 | lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */ |
896df2d5 | 255 | if (! scm_is_pair (lst)) |
5fc743b4 | 256 | goto check_lst_and_done; |
110348ae | 257 | SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */ |
eccd308a | 258 | SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */ |
110348ae KR |
259 | } |
260 | ||
00874d5f | 261 | count += scm_is_true (scm_apply (pred, args, SCM_EOL)); |
110348ae KR |
262 | } |
263 | } | |
5fc743b4 KR |
264 | |
265 | check_lst_and_done: | |
266 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list"); | |
93ccaef0 | 267 | return scm_from_long (count); |
110348ae KR |
268 | } |
269 | #undef FUNC_NAME | |
270 | ||
271 | ||
d0a634de KR |
272 | SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0, |
273 | (SCM x, SCM lst, SCM pred), | |
274 | "Return a list containing the elements of @var{lst} but with\n" | |
275 | "those equal to @var{x} deleted. The returned elements will be\n" | |
276 | "in the same order as they were in @var{lst}.\n" | |
277 | "\n" | |
278 | "Equality is determined by @var{pred}, or @code{equal?} if not\n" | |
279 | "given. An equality call is made just once for each element,\n" | |
280 | "but the order in which the calls are made on the elements is\n" | |
281 | "unspecified.\n" | |
282 | "\n" | |
283 | "The equality calls are always @code{(pred x elem)}, ie.@: the\n" | |
284 | "given @var{x} is first. This means for instance elements\n" | |
285 | "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n" | |
286 | "\n" | |
287 | "@var{lst} is not modified, but the returned list might share a\n" | |
288 | "common tail with @var{lst}.") | |
289 | #define FUNC_NAME s_scm_srfi1_delete | |
290 | { | |
d0a634de | 291 | SCM ret, *p, keeplst; |
cf9d3c47 | 292 | int count; |
d0a634de KR |
293 | |
294 | if (SCM_UNBNDP (pred)) | |
295 | return scm_delete (x, lst); | |
296 | ||
a3e92377 | 297 | SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME); |
d0a634de KR |
298 | |
299 | /* ret is the return list being constructed. p is where to append to it, | |
300 | initially &ret then SCM_CDRLOC of the last pair. lst progresses as | |
301 | elements are considered. | |
302 | ||
303 | Elements to be retained are not immediately copied, instead keeplst is | |
cf9d3c47 KR |
304 | the last pair in lst which is to be retained but not yet copied, count |
305 | is how many from there are wanted. When there's no more deletions, *p | |
306 | can be set to keeplst to share the remainder of the original lst. (The | |
307 | entire original lst if there's no deletions at all.) */ | |
d0a634de KR |
308 | |
309 | keeplst = lst; | |
cf9d3c47 | 310 | count = 0; |
d0a634de KR |
311 | p = &ret; |
312 | ||
896df2d5 | 313 | for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) |
d0a634de | 314 | { |
a3e92377 | 315 | if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (lst)))) |
d0a634de | 316 | { |
cf9d3c47 KR |
317 | /* delete this element, so copy those at keeplst */ |
318 | p = list_copy_part (keeplst, count, p); | |
d0a634de | 319 | keeplst = SCM_CDR (lst); |
cf9d3c47 KR |
320 | count = 0; |
321 | } | |
322 | else | |
323 | { | |
324 | /* keep this element */ | |
325 | count++; | |
d0a634de KR |
326 | } |
327 | } | |
328 | ||
329 | /* final retained elements */ | |
330 | *p = keeplst; | |
331 | ||
332 | /* demand that lst was a proper list */ | |
333 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); | |
334 | ||
335 | return ret; | |
336 | } | |
337 | #undef FUNC_NAME | |
338 | ||
339 | ||
340 | SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0, | |
341 | (SCM x, SCM lst, SCM pred), | |
342 | "Return a list containing the elements of @var{lst} but with\n" | |
343 | "those equal to @var{x} deleted. The returned elements will be\n" | |
344 | "in the same order as they were in @var{lst}.\n" | |
345 | "\n" | |
346 | "Equality is determined by @var{pred}, or @code{equal?} if not\n" | |
347 | "given. An equality call is made just once for each element,\n" | |
348 | "but the order in which the calls are made on the elements is\n" | |
349 | "unspecified.\n" | |
350 | "\n" | |
351 | "The equality calls are always @code{(pred x elem)}, ie.@: the\n" | |
352 | "given @var{x} is first. This means for instance elements\n" | |
353 | "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n" | |
354 | "\n" | |
355 | "@var{lst} may be modified to construct the returned list.") | |
356 | #define FUNC_NAME s_scm_srfi1_delete_x | |
357 | { | |
d0a634de KR |
358 | SCM walk; |
359 | SCM *prev; | |
360 | ||
361 | if (SCM_UNBNDP (pred)) | |
362 | return scm_delete_x (x, lst); | |
363 | ||
a3e92377 | 364 | SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME); |
d0a634de KR |
365 | |
366 | for (prev = &lst, walk = lst; | |
896df2d5 | 367 | scm_is_pair (walk); |
d0a634de KR |
368 | walk = SCM_CDR (walk)) |
369 | { | |
a3e92377 | 370 | if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (walk)))) |
d0a634de KR |
371 | *prev = SCM_CDR (walk); |
372 | else | |
373 | prev = SCM_CDRLOC (walk); | |
374 | } | |
375 | ||
376 | /* demand the input was a proper list */ | |
377 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list"); | |
378 | return lst; | |
379 | } | |
380 | #undef FUNC_NAME | |
381 | ||
382 | ||
383 | SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0, | |
384 | (SCM lst, SCM pred), | |
385 | "Return a list containing the elements of @var{lst} but without\n" | |
386 | "duplicates.\n" | |
387 | "\n" | |
388 | "When elements are equal, only the first in @var{lst} is\n" | |
389 | "retained. Equal elements can be anywhere in @var{lst}, they\n" | |
390 | "don't have to be adjacent. The returned list will have the\n" | |
391 | "retained elements in the same order as they were in @var{lst}.\n" | |
392 | "\n" | |
393 | "Equality is determined by @var{pred}, or @code{equal?} if not\n" | |
394 | "given. Calls @code{(pred x y)} are made with element @var{x}\n" | |
395 | "being before @var{y} in @var{lst}. A call is made at most once\n" | |
396 | "for each combination, but the sequence of the calls across the\n" | |
397 | "elements is unspecified.\n" | |
398 | "\n" | |
399 | "@var{lst} is not modified, but the return might share a common\n" | |
400 | "tail with @var{lst}.\n" | |
401 | "\n" | |
402 | "In the worst case, this is an @math{O(N^2)} algorithm because\n" | |
403 | "it must check each element against all those preceding it. For\n" | |
404 | "long lists it is more efficient to sort and then compare only\n" | |
405 | "adjacent elements.") | |
406 | #define FUNC_NAME s_scm_srfi1_delete_duplicates | |
407 | { | |
408 | scm_t_trampoline_2 equal_p; | |
409 | SCM ret, *p, keeplst, item, l; | |
cf9d3c47 | 410 | int count, i; |
d0a634de KR |
411 | |
412 | /* ret is the new list constructed. p is where to append, initially &ret | |
413 | then SCM_CDRLOC of the last pair. lst is advanced as each element is | |
414 | considered. | |
415 | ||
416 | Elements retained are not immediately appended to ret, instead keeplst | |
417 | is the last pair in lst which is to be kept but is not yet copied. | |
418 | Initially this is the first pair of lst, since the first element is | |
419 | always retained. | |
420 | ||
421 | *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all | |
422 | the elements retained, making the equality search loop easy. | |
423 | ||
424 | If an item must be deleted, elements from keeplst (inclusive) to lst | |
425 | (exclusive) must be copied and appended to ret. When there's no more | |
426 | deletions, *p is left set to keeplst, so ret shares structure with the | |
427 | original lst. (ret will be the entire original lst if there are no | |
428 | deletions.) */ | |
429 | ||
430 | /* skip to end if an empty list (or something invalid) */ | |
cf9d3c47 KR |
431 | ret = SCM_EOL; |
432 | ||
433 | if (SCM_UNBNDP (pred)) | |
434 | equal_p = equal_trampoline; | |
435 | else | |
d0a634de | 436 | { |
a3e92377 AW |
437 | SCM_VALIDATE_PROC (SCM_ARG2, pred); |
438 | equal_p = scm_call_2; | |
cf9d3c47 | 439 | } |
d0a634de | 440 | |
cf9d3c47 KR |
441 | keeplst = lst; |
442 | count = 0; | |
443 | p = &ret; | |
d0a634de | 444 | |
cf9d3c47 KR |
445 | for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) |
446 | { | |
447 | item = SCM_CAR (lst); | |
d0a634de | 448 | |
cf9d3c47 KR |
449 | /* look for item in "ret" list */ |
450 | for (l = ret; scm_is_pair (l); l = SCM_CDR (l)) | |
451 | { | |
452 | if (scm_is_true (equal_p (pred, SCM_CAR (l), item))) | |
d0a634de | 453 | { |
cf9d3c47 KR |
454 | /* "item" is a duplicate, so copy keeplst onto ret */ |
455 | duplicate: | |
456 | p = list_copy_part (keeplst, count, p); | |
457 | ||
458 | keeplst = SCM_CDR (lst); /* elem after the one deleted */ | |
459 | count = 0; | |
460 | goto next_elem; | |
d0a634de KR |
461 | } |
462 | } | |
d0a634de | 463 | |
cf9d3c47 KR |
464 | /* look for item in "keeplst" list |
465 | be careful traversing, in case nasty code changed the cdrs */ | |
466 | for (i = 0, l = keeplst; | |
467 | i < count && scm_is_pair (l); | |
468 | i++, l = SCM_CDR (l)) | |
469 | if (scm_is_true (equal_p (pred, SCM_CAR (l), item))) | |
470 | goto duplicate; | |
471 | ||
472 | /* keep this element */ | |
473 | count++; | |
474 | ||
475 | next_elem: | |
476 | ; | |
477 | } | |
d0a634de KR |
478 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list"); |
479 | ||
cf9d3c47 KR |
480 | /* share tail of keeplst items */ |
481 | *p = keeplst; | |
482 | ||
d0a634de KR |
483 | return ret; |
484 | } | |
485 | #undef FUNC_NAME | |
486 | ||
487 | ||
488 | SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, | |
489 | (SCM lst, SCM pred), | |
490 | "Return a list containing the elements of @var{lst} but without\n" | |
491 | "duplicates.\n" | |
492 | "\n" | |
493 | "When elements are equal, only the first in @var{lst} is\n" | |
494 | "retained. Equal elements can be anywhere in @var{lst}, they\n" | |
495 | "don't have to be adjacent. The returned list will have the\n" | |
496 | "retained elements in the same order as they were in @var{lst}.\n" | |
497 | "\n" | |
498 | "Equality is determined by @var{pred}, or @code{equal?} if not\n" | |
499 | "given. Calls @code{(pred x y)} are made with element @var{x}\n" | |
500 | "being before @var{y} in @var{lst}. A call is made at most once\n" | |
501 | "for each combination, but the sequence of the calls across the\n" | |
502 | "elements is unspecified.\n" | |
503 | "\n" | |
504 | "@var{lst} may be modified to construct the returned list.\n" | |
505 | "\n" | |
506 | "In the worst case, this is an @math{O(N^2)} algorithm because\n" | |
507 | "it must check each element against all those preceding it. For\n" | |
508 | "long lists it is more efficient to sort and then compare only\n" | |
509 | "adjacent elements.") | |
510 | #define FUNC_NAME s_scm_srfi1_delete_duplicates_x | |
511 | { | |
512 | scm_t_trampoline_2 equal_p; | |
513 | SCM ret, endret, item, l; | |
514 | ||
515 | /* ret is the return list, constructed from the pairs in lst. endret is | |
516 | the last pair of ret, initially the first pair. lst is advanced as | |
517 | elements are considered. */ | |
518 | ||
519 | /* skip to end if an empty list (or something invalid) */ | |
520 | ret = lst; | |
896df2d5 | 521 | if (scm_is_pair (lst)) |
d0a634de KR |
522 | { |
523 | if (SCM_UNBNDP (pred)) | |
524 | equal_p = equal_trampoline; | |
525 | else | |
526 | { | |
a3e92377 AW |
527 | SCM_VALIDATE_PROC (SCM_ARG2, pred); |
528 | equal_p = scm_call_2; | |
d0a634de KR |
529 | } |
530 | ||
531 | endret = ret; | |
532 | ||
533 | /* loop over lst elements starting from second */ | |
534 | for (;;) | |
535 | { | |
536 | lst = SCM_CDR (lst); | |
896df2d5 | 537 | if (! scm_is_pair (lst)) |
d0a634de KR |
538 | break; |
539 | item = SCM_CAR (lst); | |
540 | ||
541 | /* is item equal to any element from ret to endret (inclusive)? */ | |
542 | l = ret; | |
543 | for (;;) | |
544 | { | |
00874d5f | 545 | if (scm_is_true (equal_p (pred, SCM_CAR (l), item))) |
d0a634de KR |
546 | break; /* equal, forget this element */ |
547 | ||
bc36d050 | 548 | if (scm_is_eq (l, endret)) |
d0a634de KR |
549 | { |
550 | /* not equal to any, so append this pair */ | |
551 | SCM_SETCDR (endret, lst); | |
552 | endret = lst; | |
553 | break; | |
554 | } | |
555 | l = SCM_CDR (l); | |
556 | } | |
557 | } | |
558 | ||
559 | /* terminate, in case last element was deleted */ | |
560 | SCM_SETCDR (endret, SCM_EOL); | |
561 | } | |
562 | ||
563 | /* demand that lst was a proper list */ | |
564 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list"); | |
565 | ||
566 | return ret; | |
567 | } | |
568 | #undef FUNC_NAME | |
569 | ||
570 | ||
2b077051 KR |
571 | SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0, |
572 | (SCM lst, SCM n), | |
573 | "Return a new list containing all except the last @var{n}\n" | |
574 | "elements of @var{lst}.") | |
575 | #define FUNC_NAME s_scm_srfi1_drop_right | |
576 | { | |
577 | SCM tail = scm_list_tail (lst, n); | |
578 | SCM ret = SCM_EOL; | |
579 | SCM *rend = &ret; | |
580 | while (scm_is_pair (tail)) | |
581 | { | |
582 | *rend = scm_cons (SCM_CAR (lst), SCM_EOL); | |
583 | rend = SCM_CDRLOC (*rend); | |
584 | ||
585 | lst = SCM_CDR (lst); | |
586 | tail = SCM_CDR (tail); | |
587 | } | |
588 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list"); | |
589 | return ret; | |
590 | } | |
591 | #undef FUNC_NAME | |
c1635946 | 592 | |
5df2ac97 KR |
593 | SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0, |
594 | (SCM pred, SCM lst), | |
595 | "Return the first element of @var{lst} which satisfies the\n" | |
596 | "predicate @var{pred}, or return @code{#f} if no such element is\n" | |
597 | "found.") | |
598 | #define FUNC_NAME s_scm_srfi1_find | |
599 | { | |
a3e92377 | 600 | SCM_VALIDATE_PROC (SCM_ARG1, pred); |
5df2ac97 KR |
601 | |
602 | for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) | |
603 | { | |
604 | SCM elem = SCM_CAR (lst); | |
a3e92377 | 605 | if (scm_is_true (scm_call_1 (pred, elem))) |
5df2ac97 KR |
606 | return elem; |
607 | } | |
608 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); | |
609 | ||
610 | return SCM_BOOL_F; | |
611 | } | |
612 | #undef FUNC_NAME | |
613 | ||
614 | ||
615 | SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0, | |
616 | (SCM pred, SCM lst), | |
617 | "Return the first pair of @var{lst} whose @sc{car} satisfies the\n" | |
618 | "predicate @var{pred}, or return @code{#f} if no such element is\n" | |
619 | "found.") | |
620 | #define FUNC_NAME s_scm_srfi1_find_tail | |
621 | { | |
a3e92377 | 622 | SCM_VALIDATE_PROC (SCM_ARG1, pred); |
5df2ac97 KR |
623 | |
624 | for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) | |
a3e92377 | 625 | if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst)))) |
5df2ac97 KR |
626 | return lst; |
627 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); | |
628 | ||
629 | return SCM_BOOL_F; | |
630 | } | |
631 | #undef FUNC_NAME | |
632 | ||
de51f595 KR |
633 | SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, |
634 | (SCM lst), | |
635 | "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n" | |
636 | "circular.") | |
637 | #define FUNC_NAME s_scm_srfi1_length_plus | |
638 | { | |
639 | long len = scm_ilength (lst); | |
93ccaef0 | 640 | return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F); |
de51f595 KR |
641 | } |
642 | #undef FUNC_NAME | |
643 | ||
644 | ||
d61261f0 KR |
645 | /* This routine differs from the core list-copy in allowing improper lists. |
646 | Maybe the core could allow them similarly. */ | |
647 | ||
648 | SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0, | |
649 | (SCM lst), | |
650 | "Return a copy of the given list @var{lst}.\n" | |
651 | "\n" | |
652 | "@var{lst} can be a proper or improper list. And if @var{lst}\n" | |
653 | "is not a pair then it's treated as the final tail of an\n" | |
654 | "improper list and simply returned.") | |
655 | #define FUNC_NAME s_scm_srfi1_list_copy | |
656 | { | |
657 | SCM newlst; | |
658 | SCM * fill_here; | |
659 | SCM from_here; | |
660 | ||
661 | newlst = lst; | |
662 | fill_here = &newlst; | |
663 | from_here = lst; | |
664 | ||
896df2d5 | 665 | while (scm_is_pair (from_here)) |
d61261f0 KR |
666 | { |
667 | SCM c; | |
668 | c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here)); | |
669 | *fill_here = c; | |
670 | fill_here = SCM_CDRLOC (c); | |
671 | from_here = SCM_CDR (from_here); | |
672 | } | |
673 | return newlst; | |
674 | } | |
675 | #undef FUNC_NAME | |
676 | ||
9dcee2b7 KR |
677 | SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1, |
678 | (SCM equal, SCM lst, SCM rest), | |
679 | "Return @var{lst} with any elements in the lists in @var{rest}\n" | |
680 | "removed (ie.@: subtracted). For only one @var{lst} argument,\n" | |
681 | "just that list is returned.\n" | |
682 | "\n" | |
683 | "The given @var{equal} procedure is used for comparing elements,\n" | |
684 | "called as @code{(@var{equal} elem1 elemN)}. The first argument\n" | |
685 | "is from @var{lst} and the second from one of the subsequent\n" | |
686 | "lists. But exactly which calls are made and in what order is\n" | |
687 | "unspecified.\n" | |
688 | "\n" | |
689 | "@example\n" | |
690 | "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n" | |
691 | "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n" | |
692 | "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n" | |
693 | "@end example\n" | |
694 | "\n" | |
695 | "@code{lset-difference!} may modify @var{lst} to form its\n" | |
696 | "result.") | |
697 | #define FUNC_NAME s_scm_srfi1_lset_difference_x | |
698 | { | |
9dcee2b7 KR |
699 | SCM ret, *pos, elem, r, b; |
700 | int argnum; | |
701 | ||
95e59982 | 702 | SCM_VALIDATE_PROC (SCM_ARG1, equal); |
9dcee2b7 KR |
703 | SCM_VALIDATE_REST_ARGUMENT (rest); |
704 | ||
705 | ret = SCM_EOL; | |
706 | pos = &ret; | |
707 | for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) | |
708 | { | |
709 | elem = SCM_CAR (lst); | |
710 | ||
711 | for (r = rest, argnum = SCM_ARG3; | |
712 | scm_is_pair (r); | |
713 | r = SCM_CDR (r), argnum++) | |
714 | { | |
715 | for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b)) | |
a3e92377 | 716 | if (scm_is_true (scm_call_2 (equal, elem, SCM_CAR (b)))) |
9dcee2b7 KR |
717 | goto next_elem; /* equal to elem, so drop that elem */ |
718 | ||
719 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list"); | |
720 | } | |
721 | ||
722 | /* elem not equal to anything in later lists, so keep it */ | |
723 | *pos = lst; | |
724 | pos = SCM_CDRLOC (lst); | |
725 | ||
726 | next_elem: | |
727 | ; | |
728 | } | |
729 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); | |
730 | ||
731 | *pos = SCM_EOL; | |
732 | return ret; | |
733 | } | |
734 | #undef FUNC_NAME | |
735 | ||
736 | ||
7692d26b MD |
737 | SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0, |
738 | (SCM key, SCM alist, SCM pred), | |
739 | "Behaves like @code{assq} but uses third argument @var{pred?}\n" | |
740 | "for key comparison. If @var{pred?} is not supplied,\n" | |
741 | "@code{equal?} is used. (Extended from R5RS.)\n") | |
742 | #define FUNC_NAME s_scm_srfi1_assoc | |
743 | { | |
744 | SCM ls = alist; | |
745 | scm_t_trampoline_2 equal_p; | |
746 | if (SCM_UNBNDP (pred)) | |
747 | equal_p = equal_trampoline; | |
748 | else | |
749 | { | |
a3e92377 AW |
750 | SCM_VALIDATE_PROC (SCM_ARG3, pred); |
751 | equal_p = scm_call_2; | |
7692d26b | 752 | } |
896df2d5 | 753 | for(; scm_is_pair (ls); ls = SCM_CDR (ls)) |
7692d26b MD |
754 | { |
755 | SCM tmp = SCM_CAR (ls); | |
896df2d5 | 756 | SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME, |
7692d26b | 757 | "association list"); |
9a993171 | 758 | if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp)))) |
7692d26b MD |
759 | return tmp; |
760 | } | |
761 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME, | |
762 | "association list"); | |
763 | return SCM_BOOL_F; | |
764 | } | |
765 | #undef FUNC_NAME | |
766 | ||
65978fb2 KR |
767 | SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0, |
768 | (SCM pred, SCM list), | |
769 | "Partition the elements of @var{list} with predicate @var{pred}.\n" | |
ffb62a43 | 770 | "Return two values: the list of elements satisfying @var{pred} and\n" |
65978fb2 KR |
771 | "the list of elements @emph{not} satisfying @var{pred}. The order\n" |
772 | "of the output lists follows the order of @var{list}. @var{list}\n" | |
773 | "is not mutated. One of the output lists may share memory with @var{list}.\n") | |
774 | #define FUNC_NAME s_scm_srfi1_partition | |
775 | { | |
776 | /* In this implementation, the output lists don't share memory with | |
777 | list, because it's probably not worth the effort. */ | |
0fb11ae4 | 778 | SCM orig_list = list; |
65978fb2 KR |
779 | SCM kept = scm_cons(SCM_EOL, SCM_EOL); |
780 | SCM kept_tail = kept; | |
781 | SCM dropped = scm_cons(SCM_EOL, SCM_EOL); | |
782 | SCM dropped_tail = dropped; | |
783 | ||
a3e92377 | 784 | SCM_VALIDATE_PROC (SCM_ARG1, pred); |
65978fb2 KR |
785 | |
786 | for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) { | |
0fb11ae4 LC |
787 | SCM elt, new_tail; |
788 | ||
789 | /* Make sure LIST is not a dotted list. */ | |
790 | SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME); | |
791 | ||
792 | elt = SCM_CAR (list); | |
793 | new_tail = scm_cons (SCM_CAR (list), SCM_EOL); | |
794 | ||
a3e92377 | 795 | if (scm_is_true (scm_call_1 (pred, elt))) { |
65978fb2 KR |
796 | SCM_SETCDR(kept_tail, new_tail); |
797 | kept_tail = new_tail; | |
798 | } | |
799 | else { | |
800 | SCM_SETCDR(dropped_tail, new_tail); | |
801 | dropped_tail = new_tail; | |
802 | } | |
803 | } | |
804 | /* re-use the initial conses for the values list */ | |
805 | SCM_SETCAR(kept, SCM_CDR(kept)); | |
806 | SCM_SETCDR(kept, dropped); | |
807 | SCM_SETCAR(dropped, SCM_CDR(dropped)); | |
808 | SCM_SETCDR(dropped, SCM_EOL); | |
809 | return scm_values(kept); | |
810 | } | |
811 | #undef FUNC_NAME | |
812 | ||
2b077051 KR |
813 | |
814 | SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0, | |
815 | (SCM pred, SCM lst), | |
816 | "Split @var{lst} into those elements which do and don't satisfy\n" | |
817 | "the predicate @var{pred}.\n" | |
818 | "\n" | |
819 | "The return is two values (@pxref{Multiple Values}), the first\n" | |
820 | "being a list of all elements from @var{lst} which satisfy\n" | |
821 | "@var{pred}, the second a list of those which do not.\n" | |
822 | "\n" | |
823 | "The elements in the result lists are in the same order as in\n" | |
824 | "@var{lst} but the order in which the calls @code{(@var{pred}\n" | |
825 | "elem)} are made on the list elements is unspecified.\n" | |
826 | "\n" | |
827 | "@var{lst} may be modified to construct the return lists.") | |
828 | #define FUNC_NAME s_scm_srfi1_partition_x | |
829 | { | |
830 | SCM tlst, flst, *tp, *fp; | |
2b077051 | 831 | |
a3e92377 | 832 | SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME); |
2b077051 KR |
833 | |
834 | /* tlst and flst are the lists of true and false elements. tp and fp are | |
835 | where to store to append to them, initially &tlst and &flst, then | |
836 | SCM_CDRLOC of the last pair in the respective lists. */ | |
837 | ||
838 | tlst = SCM_EOL; | |
839 | flst = SCM_EOL; | |
840 | tp = &tlst; | |
841 | fp = &flst; | |
842 | ||
843 | for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) | |
844 | { | |
a3e92377 | 845 | if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst)))) |
2b077051 KR |
846 | { |
847 | *tp = lst; | |
848 | tp = SCM_CDRLOC (lst); | |
849 | } | |
850 | else | |
851 | { | |
852 | *fp = lst; | |
853 | fp = SCM_CDRLOC (lst); | |
854 | } | |
855 | } | |
856 | ||
857 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); | |
858 | ||
859 | /* terminate whichever didn't get the last element(s) */ | |
860 | *tp = SCM_EOL; | |
861 | *fp = SCM_EOL; | |
862 | ||
863 | return scm_values (scm_list_2 (tlst, flst)); | |
864 | } | |
865 | #undef FUNC_NAME | |
866 | ||
59747b8d KR |
867 | SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0, |
868 | (SCM pred, SCM list), | |
869 | "Return a list containing all elements from @var{lst} which do\n" | |
870 | "not satisfy the predicate @var{pred}. The elements in the\n" | |
871 | "result list have the same order as in @var{lst}. The order in\n" | |
872 | "which @var{pred} is applied to the list elements is not\n" | |
873 | "specified.") | |
874 | #define FUNC_NAME s_scm_srfi1_remove | |
875 | { | |
59747b8d KR |
876 | SCM walk; |
877 | SCM *prev; | |
878 | SCM res = SCM_EOL; | |
a3e92377 | 879 | SCM_VALIDATE_PROC (SCM_ARG1, pred); |
59747b8d KR |
880 | SCM_VALIDATE_LIST (2, list); |
881 | ||
882 | for (prev = &res, walk = list; | |
883 | scm_is_pair (walk); | |
884 | walk = SCM_CDR (walk)) | |
885 | { | |
a3e92377 | 886 | if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk)))) |
59747b8d KR |
887 | { |
888 | *prev = scm_cons (SCM_CAR (walk), SCM_EOL); | |
889 | prev = SCM_CDRLOC (*prev); | |
890 | } | |
891 | } | |
892 | ||
893 | return res; | |
894 | } | |
895 | #undef FUNC_NAME | |
896 | ||
2b077051 KR |
897 | |
898 | SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0, | |
899 | (SCM pred, SCM list), | |
900 | "Return a list containing all elements from @var{list} which do\n" | |
901 | "not satisfy the predicate @var{pred}. The elements in the\n" | |
902 | "result list have the same order as in @var{list}. The order in\n" | |
903 | "which @var{pred} is applied to the list elements is not\n" | |
904 | "specified. @var{list} may be modified to build the return\n" | |
905 | "list.") | |
906 | #define FUNC_NAME s_scm_srfi1_remove_x | |
907 | { | |
2b077051 KR |
908 | SCM walk; |
909 | SCM *prev; | |
a3e92377 | 910 | SCM_VALIDATE_PROC (SCM_ARG1, pred); |
2b077051 KR |
911 | SCM_VALIDATE_LIST (2, list); |
912 | ||
913 | for (prev = &list, walk = list; | |
914 | scm_is_pair (walk); | |
915 | walk = SCM_CDR (walk)) | |
916 | { | |
a3e92377 | 917 | if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk)))) |
2b077051 KR |
918 | prev = SCM_CDRLOC (walk); |
919 | else | |
920 | *prev = SCM_CDR (walk); | |
921 | } | |
922 | ||
923 | return list; | |
924 | } | |
925 | #undef FUNC_NAME | |
926 | ||
2b077051 KR |
927 | SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0, |
928 | (SCM lst, SCM n), | |
ffb62a43 | 929 | "Return a list containing the @var{n} last elements of\n" |
2b077051 KR |
930 | "@var{lst}.") |
931 | #define FUNC_NAME s_scm_srfi1_take_right | |
932 | { | |
933 | SCM tail = scm_list_tail (lst, n); | |
934 | while (scm_is_pair (tail)) | |
935 | { | |
936 | lst = SCM_CDR (lst); | |
937 | tail = SCM_CDR (tail); | |
938 | } | |
939 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list"); | |
940 | return lst; | |
941 | } | |
942 | #undef FUNC_NAME | |
943 | ||
0b7f2eb8 | 944 | \f |
37710f7e AW |
945 | void |
946 | scm_register_srfi_1 (void) | |
947 | { | |
948 | scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, | |
949 | "scm_init_srfi_1", | |
950 | (scm_t_extension_init_func)scm_init_srfi_1, NULL); | |
951 | } | |
952 | ||
ee6aac97 MD |
953 | void |
954 | scm_init_srfi_1 (void) | |
955 | { | |
956 | #ifndef SCM_MAGIC_SNARFER | |
37710f7e | 957 | #include "libguile/srfi-1.x" |
ee6aac97 MD |
958 | #endif |
959 | } | |
960 | ||
961 | /* End of srfi-1.c. */ |