1 |
/* srfi-1.c --- SRFI-1 procedures for Guile |
/* srfi-1.c --- SRFI-1 procedures for Guile |
2 |
* |
* |
3 |
* Copyright (C) 2002, 2003 Free Software Foundation, Inc. |
* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003 Free Software |
4 |
|
* Foundation, Inc. |
5 |
* |
* |
6 |
* This library is free software; you can redistribute it and/or |
* This library is free software; you can redistribute it and/or |
7 |
* modify it under the terms of the GNU Lesser General Public |
* modify it under the terms of the GNU Lesser General Public |
56 |
return -1; |
return -1; |
57 |
} |
} |
58 |
|
|
59 |
|
static SCM |
60 |
|
equal_trampoline (SCM proc, SCM arg1, SCM arg2) |
61 |
|
{ |
62 |
|
return scm_equal_p (arg1, arg2); |
63 |
|
} |
64 |
|
|
65 |
|
|
66 |
|
SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0, |
67 |
|
(SCM x, SCM lst, SCM pred), |
68 |
|
"Return a list containing the elements of @var{lst} but with\n" |
69 |
|
"those equal to @var{x} deleted. The returned elements will be\n" |
70 |
|
"in the same order as they were in @var{lst}.\n" |
71 |
|
"\n" |
72 |
|
"Equality is determined by @var{pred}, or @code{equal?} if not\n" |
73 |
|
"given. An equality call is made just once for each element,\n" |
74 |
|
"but the order in which the calls are made on the elements is\n" |
75 |
|
"unspecified.\n" |
76 |
|
"\n" |
77 |
|
"The equality calls are always @code{(pred x elem)}, ie.@: the\n" |
78 |
|
"given @var{x} is first. This means for instance elements\n" |
79 |
|
"greater than 5 can be deleted with @code{(delete 5 lst <)}.\n" |
80 |
|
"\n" |
81 |
|
"@var{lst} is not modified, but the returned list might share a\n" |
82 |
|
"common tail with @var{lst}.") |
83 |
|
#define FUNC_NAME s_scm_srfi1_delete |
84 |
|
{ |
85 |
|
scm_t_trampoline_2 equal_p; |
86 |
|
SCM ret, *p, keeplst; |
87 |
|
|
88 |
|
if (SCM_UNBNDP (pred)) |
89 |
|
return scm_delete (x, lst); |
90 |
|
|
91 |
|
equal_p = scm_trampoline_2 (pred); |
92 |
|
SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME); |
93 |
|
|
94 |
|
/* ret is the return list being constructed. p is where to append to it, |
95 |
|
initially &ret then SCM_CDRLOC of the last pair. lst progresses as |
96 |
|
elements are considered. |
97 |
|
|
98 |
|
Elements to be retained are not immediately copied, instead keeplst is |
99 |
|
the last pair in lst which is to be retained but not yet copied. When |
100 |
|
there's no more deletions, *p can be set to keeplst to share the |
101 |
|
remainder of the original lst. (The entire original lst if there's no |
102 |
|
deletions at all.) */ |
103 |
|
|
104 |
|
keeplst = lst; |
105 |
|
ret = SCM_EOL; |
106 |
|
p = &ret; |
107 |
|
|
108 |
|
for ( ; SCM_CONSP (lst); lst = SCM_CDR (lst)) |
109 |
|
{ |
110 |
|
if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (lst)))) |
111 |
|
{ |
112 |
|
/* delete this element, so copy from keeplst (inclusive) to lst |
113 |
|
(exclusive) onto ret */ |
114 |
|
while (! SCM_EQ_P (keeplst, lst)) |
115 |
|
{ |
116 |
|
SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL); |
117 |
|
*p = c; |
118 |
|
p = SCM_CDRLOC (c); |
119 |
|
keeplst = SCM_CDR (keeplst); |
120 |
|
} |
121 |
|
|
122 |
|
keeplst = SCM_CDR (lst); |
123 |
|
} |
124 |
|
} |
125 |
|
|
126 |
|
/* final retained elements */ |
127 |
|
*p = keeplst; |
128 |
|
|
129 |
|
/* demand that lst was a proper list */ |
130 |
|
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list"); |
131 |
|
|
132 |
|
return ret; |
133 |
|
} |
134 |
|
#undef FUNC_NAME |
135 |
|
|
136 |
|
|
137 |
|
SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0, |
138 |
|
(SCM x, SCM lst, SCM pred), |
139 |
|
"Return a list containing the elements of @var{lst} but with\n" |
140 |
|
"those equal to @var{x} deleted. The returned elements will be\n" |
141 |
|
"in the same order as they were in @var{lst}.\n" |
142 |
|
"\n" |
143 |
|
"Equality is determined by @var{pred}, or @code{equal?} if not\n" |
144 |
|
"given. An equality call is made just once for each element,\n" |
145 |
|
"but the order in which the calls are made on the elements is\n" |
146 |
|
"unspecified.\n" |
147 |
|
"\n" |
148 |
|
"The equality calls are always @code{(pred x elem)}, ie.@: the\n" |
149 |
|
"given @var{x} is first. This means for instance elements\n" |
150 |
|
"greater than 5 can be deleted with @code{(delete 5 lst <)}.\n" |
151 |
|
"\n" |
152 |
|
"@var{lst} may be modified to construct the returned list.") |
153 |
|
#define FUNC_NAME s_scm_srfi1_delete_x |
154 |
|
{ |
155 |
|
scm_t_trampoline_2 equal_p; |
156 |
|
SCM walk; |
157 |
|
SCM *prev; |
158 |
|
|
159 |
|
if (SCM_UNBNDP (pred)) |
160 |
|
return scm_delete_x (x, lst); |
161 |
|
|
162 |
|
equal_p = scm_trampoline_2 (pred); |
163 |
|
SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME); |
164 |
|
|
165 |
|
for (prev = &lst, walk = lst; |
166 |
|
SCM_CONSP (walk); |
167 |
|
walk = SCM_CDR (walk)) |
168 |
|
{ |
169 |
|
if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (walk)))) |
170 |
|
*prev = SCM_CDR (walk); |
171 |
|
else |
172 |
|
prev = SCM_CDRLOC (walk); |
173 |
|
} |
174 |
|
|
175 |
|
/* demand the input was a proper list */ |
176 |
|
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list"); |
177 |
|
return lst; |
178 |
|
} |
179 |
|
#undef FUNC_NAME |
180 |
|
|
181 |
|
|
182 |
|
SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0, |
183 |
|
(SCM lst, SCM pred), |
184 |
|
"Return a list containing the elements of @var{lst} but without\n" |
185 |
|
"duplicates.\n" |
186 |
|
"\n" |
187 |
|
"When elements are equal, only the first in @var{lst} is\n" |
188 |
|
"retained. Equal elements can be anywhere in @var{lst}, they\n" |
189 |
|
"don't have to be adjacent. The returned list will have the\n" |
190 |
|
"retained elements in the same order as they were in @var{lst}.\n" |
191 |
|
"\n" |
192 |
|
"Equality is determined by @var{pred}, or @code{equal?} if not\n" |
193 |
|
"given. Calls @code{(pred x y)} are made with element @var{x}\n" |
194 |
|
"being before @var{y} in @var{lst}. A call is made at most once\n" |
195 |
|
"for each combination, but the sequence of the calls across the\n" |
196 |
|
"elements is unspecified.\n" |
197 |
|
"\n" |
198 |
|
"@var{lst} is not modified, but the return might share a common\n" |
199 |
|
"tail with @var{lst}.\n" |
200 |
|
"\n" |
201 |
|
"In the worst case, this is an @math{O(N^2)} algorithm because\n" |
202 |
|
"it must check each element against all those preceding it. For\n" |
203 |
|
"long lists it is more efficient to sort and then compare only\n" |
204 |
|
"adjacent elements.") |
205 |
|
#define FUNC_NAME s_scm_srfi1_delete_duplicates |
206 |
|
{ |
207 |
|
scm_t_trampoline_2 equal_p; |
208 |
|
SCM ret, *p, keeplst, item, l; |
209 |
|
|
210 |
|
/* ret is the new list constructed. p is where to append, initially &ret |
211 |
|
then SCM_CDRLOC of the last pair. lst is advanced as each element is |
212 |
|
considered. |
213 |
|
|
214 |
|
Elements retained are not immediately appended to ret, instead keeplst |
215 |
|
is the last pair in lst which is to be kept but is not yet copied. |
216 |
|
Initially this is the first pair of lst, since the first element is |
217 |
|
always retained. |
218 |
|
|
219 |
|
*p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all |
220 |
|
the elements retained, making the equality search loop easy. |
221 |
|
|
222 |
|
If an item must be deleted, elements from keeplst (inclusive) to lst |
223 |
|
(exclusive) must be copied and appended to ret. When there's no more |
224 |
|
deletions, *p is left set to keeplst, so ret shares structure with the |
225 |
|
original lst. (ret will be the entire original lst if there are no |
226 |
|
deletions.) */ |
227 |
|
|
228 |
|
/* skip to end if an empty list (or something invalid) */ |
229 |
|
ret = lst; |
230 |
|
if (SCM_CONSP (lst)) |
231 |
|
{ |
232 |
|
if (SCM_UNBNDP (pred)) |
233 |
|
equal_p = equal_trampoline; |
234 |
|
else |
235 |
|
{ |
236 |
|
equal_p = scm_trampoline_2 (pred); |
237 |
|
SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME); |
238 |
|
} |
239 |
|
|
240 |
|
keeplst = lst; |
241 |
|
p = &ret; |
242 |
|
|
243 |
|
/* loop over lst elements starting from second */ |
244 |
|
for (;;) |
245 |
|
{ |
246 |
|
lst = SCM_CDR (lst); |
247 |
|
if (! SCM_CONSP (lst)) |
248 |
|
break; |
249 |
|
item = SCM_CAR (lst); |
250 |
|
|
251 |
|
/* loop searching ret upto lst */ |
252 |
|
for (l = ret; ! SCM_EQ_P (l, lst); l = SCM_CDR (l)) |
253 |
|
{ |
254 |
|
if (! SCM_FALSEP (equal_p (pred, SCM_CAR (l), item))) |
255 |
|
{ |
256 |
|
/* duplicate, don't want this element, so copy keeplst |
257 |
|
(inclusive) to lst (exclusive) onto ret */ |
258 |
|
while (! SCM_EQ_P (keeplst, lst)) |
259 |
|
{ |
260 |
|
SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL); |
261 |
|
*p = c; |
262 |
|
p = SCM_CDRLOC (c); |
263 |
|
keeplst = SCM_CDR (keeplst); |
264 |
|
} |
265 |
|
|
266 |
|
keeplst = SCM_CDR (lst); /* elem after the one deleted */ |
267 |
|
*p = keeplst; |
268 |
|
break; |
269 |
|
} |
270 |
|
} |
271 |
|
} |
272 |
|
} |
273 |
|
|
274 |
|
/* demand that lst was a proper list */ |
275 |
|
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list"); |
276 |
|
|
277 |
|
return ret; |
278 |
|
} |
279 |
|
#undef FUNC_NAME |
280 |
|
|
281 |
|
|
282 |
|
SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, |
283 |
|
(SCM lst, SCM pred), |
284 |
|
"Return a list containing the elements of @var{lst} but without\n" |
285 |
|
"duplicates.\n" |
286 |
|
"\n" |
287 |
|
"When elements are equal, only the first in @var{lst} is\n" |
288 |
|
"retained. Equal elements can be anywhere in @var{lst}, they\n" |
289 |
|
"don't have to be adjacent. The returned list will have the\n" |
290 |
|
"retained elements in the same order as they were in @var{lst}.\n" |
291 |
|
"\n" |
292 |
|
"Equality is determined by @var{pred}, or @code{equal?} if not\n" |
293 |
|
"given. Calls @code{(pred x y)} are made with element @var{x}\n" |
294 |
|
"being before @var{y} in @var{lst}. A call is made at most once\n" |
295 |
|
"for each combination, but the sequence of the calls across the\n" |
296 |
|
"elements is unspecified.\n" |
297 |
|
"\n" |
298 |
|
"@var{lst} may be modified to construct the returned list.\n" |
299 |
|
"\n" |
300 |
|
"In the worst case, this is an @math{O(N^2)} algorithm because\n" |
301 |
|
"it must check each element against all those preceding it. For\n" |
302 |
|
"long lists it is more efficient to sort and then compare only\n" |
303 |
|
"adjacent elements.") |
304 |
|
#define FUNC_NAME s_scm_srfi1_delete_duplicates_x |
305 |
|
{ |
306 |
|
scm_t_trampoline_2 equal_p; |
307 |
|
SCM ret, endret, item, l; |
308 |
|
|
309 |
|
/* ret is the return list, constructed from the pairs in lst. endret is |
310 |
|
the last pair of ret, initially the first pair. lst is advanced as |
311 |
|
elements are considered. */ |
312 |
|
|
313 |
|
/* skip to end if an empty list (or something invalid) */ |
314 |
|
ret = lst; |
315 |
|
if (SCM_CONSP (lst)) |
316 |
|
{ |
317 |
|
if (SCM_UNBNDP (pred)) |
318 |
|
equal_p = equal_trampoline; |
319 |
|
else |
320 |
|
{ |
321 |
|
equal_p = scm_trampoline_2 (pred); |
322 |
|
SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME); |
323 |
|
} |
324 |
|
|
325 |
|
endret = ret; |
326 |
|
|
327 |
|
/* loop over lst elements starting from second */ |
328 |
|
for (;;) |
329 |
|
{ |
330 |
|
lst = SCM_CDR (lst); |
331 |
|
if (! SCM_CONSP (lst)) |
332 |
|
break; |
333 |
|
item = SCM_CAR (lst); |
334 |
|
|
335 |
|
/* is item equal to any element from ret to endret (inclusive)? */ |
336 |
|
l = ret; |
337 |
|
for (;;) |
338 |
|
{ |
339 |
|
if (! SCM_FALSEP (equal_p (pred, SCM_CAR (l), item))) |
340 |
|
break; /* equal, forget this element */ |
341 |
|
|
342 |
|
if (SCM_EQ_P (l, endret)) |
343 |
|
{ |
344 |
|
/* not equal to any, so append this pair */ |
345 |
|
SCM_SETCDR (endret, lst); |
346 |
|
endret = lst; |
347 |
|
break; |
348 |
|
} |
349 |
|
l = SCM_CDR (l); |
350 |
|
} |
351 |
|
} |
352 |
|
|
353 |
|
/* terminate, in case last element was deleted */ |
354 |
|
SCM_SETCDR (endret, SCM_EOL); |
355 |
|
} |
356 |
|
|
357 |
|
/* demand that lst was a proper list */ |
358 |
|
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list"); |
359 |
|
|
360 |
|
return ret; |
361 |
|
} |
362 |
|
#undef FUNC_NAME |
363 |
|
|
364 |
|
|
365 |
/* Typechecking for multi-argument MAP and FOR-EACH. |
/* Typechecking for multi-argument MAP and FOR-EACH. |
366 |
|
|
367 |
Verify that each element of the vector ARGV, except for the first, |
Verify that each element of the vector ARGV, except for the first, |
560 |
#undef FUNC_NAME |
#undef FUNC_NAME |
561 |
|
|
562 |
|
|
|
static SCM |
|
|
equal_trampoline (SCM proc, SCM arg1, SCM arg2) |
|
|
{ |
|
|
return scm_equal_p (arg1, arg2); |
|
|
} |
|
|
|
|
563 |
SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0, |
SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0, |
564 |
(SCM x, SCM lst, SCM pred), |
(SCM x, SCM lst, SCM pred), |
565 |
"Return the first sublist of @var{lst} whose car is\n" |
"Return the first sublist of @var{lst} whose car is\n" |