Commit | Line | Data |
---|---|---|
ee6aac97 MD |
1 | /* srfi-1.c --- SRFI-1 procedures for Guile |
2 | * | |
f9ac1c2d | 3 | * Copyright (C) 2002, 2003 Free Software Foundation, Inc. |
ee6aac97 | 4 | * |
73be1d9e MV |
5 | * This library is free software; you can redistribute it and/or |
6 | * modify it under the terms of the GNU Lesser General Public | |
7 | * License as published by the Free Software Foundation; either | |
8 | * version 2.1 of the License, or (at your option) any later version. | |
ee6aac97 | 9 | * |
73be1d9e MV |
10 | * This library is distributed in the hope that it will be useful, |
11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | * Lesser General Public License for more details. | |
ee6aac97 | 14 | * |
73be1d9e MV |
15 | * You should have received a copy of the GNU Lesser General Public |
16 | * License along with this library; if not, write to the Free Software | |
17 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
18 | */ | |
ee6aac97 MD |
19 | |
20 | #include <libguile.h> | |
21 | #include <libguile/lang.h> | |
22 | ||
23 | #include "srfi-1.h" | |
24 | ||
25 | /* The intent of this file is to gradually replace those Scheme | |
26 | * procedures in srfi-1.scm which extends core primitive procedures, | |
27 | * so that using srfi-1 won't have performance penalties. | |
28 | * | |
29 | * Please feel free to contribute any new replacements! | |
30 | */ | |
31 | ||
32 | static long | |
33 | srfi1_ilength (SCM sx) | |
34 | { | |
35 | long i = 0; | |
36 | SCM tortoise = sx; | |
37 | SCM hare = sx; | |
38 | ||
39 | do { | |
40 | if (SCM_NULL_OR_NIL_P(hare)) return i; | |
1685446c | 41 | if (!SCM_CONSP (hare)) return -2; |
ee6aac97 MD |
42 | hare = SCM_CDR(hare); |
43 | i++; | |
44 | if (SCM_NULL_OR_NIL_P(hare)) return i; | |
1685446c | 45 | if (!SCM_CONSP (hare)) return -2; |
ee6aac97 MD |
46 | hare = SCM_CDR(hare); |
47 | i++; | |
48 | /* For every two steps the hare takes, the tortoise takes one. */ | |
49 | tortoise = SCM_CDR(tortoise); | |
50 | } | |
51 | while (! SCM_EQ_P (hare, tortoise)); | |
52 | ||
53 | /* If the tortoise ever catches the hare, then the list must contain | |
54 | a cycle. */ | |
55 | return -1; | |
56 | } | |
57 | ||
58 | /* Typechecking for multi-argument MAP and FOR-EACH. | |
59 | ||
60 | Verify that each element of the vector ARGV, except for the first, | |
61 | is a list and return minimum length. Attribute errors to WHO, | |
62 | and claim that the i'th element of ARGV is WHO's i+2'th argument. */ | |
63 | static inline int | |
64 | check_map_args (SCM argv, | |
65 | long len, | |
66 | SCM gf, | |
67 | SCM proc, | |
68 | SCM args, | |
69 | const char *who) | |
70 | { | |
71 | SCM const *ve = SCM_VELTS (argv); | |
72 | long i; | |
73 | ||
74 | for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--) | |
75 | { | |
76 | long elt_len; | |
77 | ||
78 | if (!(SCM_NULLP (ve[i]) || SCM_CONSP (ve[i]))) | |
79 | { | |
80 | check_map_error: | |
81 | if (gf) | |
82 | scm_apply_generic (gf, scm_cons (proc, args)); | |
83 | else | |
84 | scm_wrong_type_arg (who, i + 2, ve[i]); | |
85 | } | |
86 | ||
87 | elt_len = srfi1_ilength (ve[i]); | |
88 | if (elt_len < -1) | |
89 | goto check_map_error; | |
90 | ||
91 | if (len < 0 || (elt_len >= 0 && elt_len < len)) | |
92 | len = elt_len; | |
93 | } | |
94 | if (len < 0) | |
95 | /* i == 0 */ | |
96 | goto check_map_error; | |
97 | ||
98 | scm_remember_upto_here_1 (argv); | |
99 | return len; | |
100 | } | |
101 | ||
102 | ||
103 | SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map); | |
104 | ||
105 | /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s) | |
106 | sequentially, starting with the first element(s). This is used in | |
107 | the Scheme procedure `map-in-order', which guarantees sequential | |
108 | behaviour, is implemented using scm_map. If the behaviour changes, | |
109 | we need to update `map-in-order'. | |
110 | */ | |
111 | ||
112 | SCM | |
113 | scm_srfi1_map (SCM proc, SCM arg1, SCM args) | |
114 | #define FUNC_NAME s_srfi1_map | |
115 | { | |
116 | long i, len; | |
117 | SCM res = SCM_EOL; | |
118 | SCM *pres = &res; | |
119 | SCM const *ve = &args; /* Keep args from being optimized away. */ | |
120 | ||
121 | len = srfi1_ilength (arg1); | |
122 | SCM_GASSERTn ((SCM_NULLP (arg1) || SCM_CONSP (arg1)) && len >= -1, | |
123 | g_srfi1_map, | |
124 | scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map); | |
125 | SCM_VALIDATE_REST_ARGUMENT (args); | |
126 | if (SCM_NULLP (args)) | |
127 | { | |
128 | scm_t_trampoline_1 call = scm_trampoline_1 (proc); | |
129 | SCM_GASSERT2 (call, g_srfi1_map, proc, arg1, SCM_ARG1, s_srfi1_map); | |
130 | SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map); | |
131 | while (SCM_NIMP (arg1)) | |
132 | { | |
133 | *pres = scm_list_1 (call (proc, SCM_CAR (arg1))); | |
134 | pres = SCM_CDRLOC (*pres); | |
135 | arg1 = SCM_CDR (arg1); | |
136 | } | |
137 | return res; | |
138 | } | |
139 | if (SCM_NULLP (SCM_CDR (args))) | |
140 | { | |
141 | SCM arg2 = SCM_CAR (args); | |
142 | int len2 = srfi1_ilength (arg2); | |
143 | scm_t_trampoline_2 call = scm_trampoline_2 (proc); | |
144 | SCM_GASSERTn (call, g_srfi1_map, | |
145 | scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map); | |
146 | if (len < 0 || (len2 >= 0 && len2 < len)) | |
147 | len = len2; | |
148 | SCM_GASSERTn ((SCM_NULLP (arg2) || SCM_CONSP (arg2)) | |
149 | && len >= 0 && len2 >= -1, | |
150 | g_srfi1_map, | |
151 | scm_cons2 (proc, arg1, args), | |
f9ac1c2d | 152 | len2 >= 0 ? SCM_ARG2 : SCM_ARG3, |
ee6aac97 MD |
153 | s_srfi1_map); |
154 | while (len > 0) | |
155 | { | |
156 | *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2))); | |
157 | pres = SCM_CDRLOC (*pres); | |
158 | arg1 = SCM_CDR (arg1); | |
159 | arg2 = SCM_CDR (arg2); | |
160 | --len; | |
161 | } | |
162 | return res; | |
163 | } | |
164 | args = scm_vector (arg1 = scm_cons (arg1, args)); | |
165 | ve = SCM_VELTS (args); | |
166 | len = check_map_args (args, len, g_srfi1_map, proc, arg1, s_srfi1_map); | |
167 | while (len > 0) | |
168 | { | |
169 | arg1 = SCM_EOL; | |
170 | for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) | |
171 | { | |
172 | arg1 = scm_cons (SCM_CAR (ve[i]), arg1); | |
173 | SCM_VECTOR_SET (args, i, SCM_CDR (ve[i])); | |
174 | } | |
175 | *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL)); | |
176 | pres = SCM_CDRLOC (*pres); | |
177 | --len; | |
178 | } | |
179 | return res; | |
180 | } | |
181 | #undef FUNC_NAME | |
182 | ||
183 | SCM_REGISTER_PROC (s_srfi1_map_in_order, "map-in-order", 2, 0, 1, scm_srfi1_map); | |
184 | ||
185 | SCM_GPROC (s_srfi1_for_each, "for-each", 2, 0, 1, scm_srfi1_for_each, g_srfi1_for_each); | |
186 | ||
187 | SCM | |
188 | scm_srfi1_for_each (SCM proc, SCM arg1, SCM args) | |
189 | #define FUNC_NAME s_srfi1_for_each | |
190 | { | |
191 | SCM const *ve = &args; /* Keep args from being optimized away. */ | |
192 | long i, len; | |
193 | len = srfi1_ilength (arg1); | |
194 | SCM_GASSERTn ((SCM_NULLP (arg1) || SCM_CONSP (arg1)) && len >= -1, | |
195 | g_srfi1_for_each, scm_cons2 (proc, arg1, args), | |
196 | SCM_ARG2, s_srfi1_for_each); | |
197 | SCM_VALIDATE_REST_ARGUMENT (args); | |
198 | if (SCM_NULLP (args)) | |
199 | { | |
200 | scm_t_trampoline_1 call = scm_trampoline_1 (proc); | |
201 | SCM_GASSERT2 (call, g_srfi1_for_each, proc, arg1, | |
202 | SCM_ARG1, s_srfi1_for_each); | |
203 | SCM_GASSERT2 (len >= 0, g_srfi1_for_each, proc, arg1, | |
204 | SCM_ARG2, s_srfi1_map); | |
205 | while (SCM_NIMP (arg1)) | |
206 | { | |
207 | call (proc, SCM_CAR (arg1)); | |
208 | arg1 = SCM_CDR (arg1); | |
209 | } | |
210 | return SCM_UNSPECIFIED; | |
211 | } | |
212 | if (SCM_NULLP (SCM_CDR (args))) | |
213 | { | |
214 | SCM arg2 = SCM_CAR (args); | |
215 | int len2 = srfi1_ilength (arg2); | |
216 | scm_t_trampoline_2 call = scm_trampoline_2 (proc); | |
217 | SCM_GASSERTn (call, g_srfi1_for_each, | |
218 | scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each); | |
219 | if (len < 0 || (len2 >= 0 && len2 < len)) | |
220 | len = len2; | |
221 | SCM_GASSERTn ((SCM_NULLP (arg2) || SCM_CONSP (arg2)) | |
f9ac1c2d | 222 | && len >= 0 && len2 >= -1, |
ee6aac97 MD |
223 | g_srfi1_for_each, |
224 | scm_cons2 (proc, arg1, args), | |
f9ac1c2d | 225 | len2 >= 0 ? SCM_ARG2 : SCM_ARG3, |
ee6aac97 MD |
226 | s_srfi1_for_each); |
227 | while (len > 0) | |
228 | { | |
229 | call (proc, SCM_CAR (arg1), SCM_CAR (arg2)); | |
230 | arg1 = SCM_CDR (arg1); | |
231 | arg2 = SCM_CDR (arg2); | |
232 | --len; | |
233 | } | |
234 | return SCM_UNSPECIFIED; | |
235 | } | |
236 | args = scm_vector (arg1 = scm_cons (arg1, args)); | |
237 | ve = SCM_VELTS (args); | |
238 | len = check_map_args (args, len, g_srfi1_for_each, proc, arg1, | |
239 | s_srfi1_for_each); | |
240 | while (len > 0) | |
241 | { | |
242 | arg1 = SCM_EOL; | |
243 | for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) | |
244 | { | |
245 | arg1 = scm_cons (SCM_CAR (ve[i]), arg1); | |
246 | SCM_VECTOR_SET (args, i, SCM_CDR (ve[i])); | |
247 | } | |
248 | scm_apply (proc, arg1, SCM_EOL); | |
249 | --len; | |
250 | } | |
251 | return SCM_UNSPECIFIED; | |
252 | } | |
253 | #undef FUNC_NAME | |
254 | ||
255 | ||
256 | static SCM | |
257 | equal_trampoline (SCM proc, SCM arg1, SCM arg2) | |
258 | { | |
259 | return scm_equal_p (arg1, arg2); | |
260 | } | |
261 | ||
262 | SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0, | |
263 | (SCM x, SCM lst, SCM pred), | |
264 | "Return the first sublist of @var{lst} whose car is\n" | |
7692d26b | 265 | "@var{equal?} to @var{x} where the sublists of @var{lst} are\n" |
ee6aac97 MD |
266 | "the non-empty lists returned by @code{(list-tail @var{lst}\n" |
267 | "@var{k})} for @var{k} less than the length of @var{lst}. If\n" | |
268 | "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n" | |
7692d26b MD |
269 | "empty list) is returned. If optional third argument @var{equal?}\n" |
270 | "isn't given, @code{equal?} is used for comparison.\n" | |
271 | "(Extended from R5RS.)\n") | |
ee6aac97 MD |
272 | #define FUNC_NAME s_scm_srfi1_member |
273 | { | |
274 | scm_t_trampoline_2 equal_p; | |
275 | SCM_VALIDATE_LIST (2, lst); | |
276 | if (SCM_UNBNDP (pred)) | |
277 | equal_p = equal_trampoline; | |
278 | else | |
279 | { | |
280 | equal_p = scm_trampoline_2 (pred); | |
281 | SCM_ASSERT (equal_p, pred, 3, FUNC_NAME); | |
282 | } | |
283 | for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst)) | |
284 | { | |
285 | if (!SCM_FALSEP (equal_p (pred, SCM_CAR (lst), x))) | |
286 | return lst; | |
287 | } | |
288 | return SCM_BOOL_F; | |
289 | } | |
290 | #undef FUNC_NAME | |
291 | ||
7692d26b MD |
292 | SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0, |
293 | (SCM key, SCM alist, SCM pred), | |
294 | "Behaves like @code{assq} but uses third argument @var{pred?}\n" | |
295 | "for key comparison. If @var{pred?} is not supplied,\n" | |
296 | "@code{equal?} is used. (Extended from R5RS.)\n") | |
297 | #define FUNC_NAME s_scm_srfi1_assoc | |
298 | { | |
299 | SCM ls = alist; | |
300 | scm_t_trampoline_2 equal_p; | |
301 | if (SCM_UNBNDP (pred)) | |
302 | equal_p = equal_trampoline; | |
303 | else | |
304 | { | |
305 | equal_p = scm_trampoline_2 (pred); | |
306 | SCM_ASSERT (equal_p, pred, 3, FUNC_NAME); | |
307 | } | |
308 | for(; SCM_CONSP (ls); ls = SCM_CDR (ls)) | |
309 | { | |
310 | SCM tmp = SCM_CAR (ls); | |
311 | SCM_ASSERT_TYPE (SCM_CONSP (tmp), alist, SCM_ARG2, FUNC_NAME, | |
312 | "association list"); | |
313 | if (SCM_NFALSEP (equal_p (pred, SCM_CAR (tmp), key))) | |
314 | return tmp; | |
315 | } | |
316 | SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME, | |
317 | "association list"); | |
318 | return SCM_BOOL_F; | |
319 | } | |
320 | #undef FUNC_NAME | |
321 | ||
ee6aac97 MD |
322 | void |
323 | scm_init_srfi_1 (void) | |
324 | { | |
a48d60b1 | 325 | SCM the_root_module = scm_lookup_closure_module (SCM_BOOL_F); |
ee6aac97 MD |
326 | #ifndef SCM_MAGIC_SNARFER |
327 | #include "srfi/srfi-1.x" | |
328 | #endif | |
a48d60b1 MD |
329 | scm_c_extend_primitive_generic |
330 | (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "map")), | |
331 | SCM_VARIABLE_REF (scm_c_lookup ("map"))); | |
332 | scm_c_extend_primitive_generic | |
333 | (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "for-each")), | |
334 | SCM_VARIABLE_REF (scm_c_lookup ("for-each"))); | |
ee6aac97 MD |
335 | } |
336 | ||
337 | /* End of srfi-1.c. */ |