1 /* srfi-1.c --- SRFI-1 procedures for Guile
3 * Copyright (C) 2002, 2003 Free Software Foundation, Inc.
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.
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.
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
21 #include <libguile/lang.h>
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.
29 * Please feel free to contribute any new replacements!
33 srfi1_ilength (SCM sx
)
40 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
41 if (!SCM_CONSP (hare
)) return -2;
44 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
45 if (!SCM_CONSP (hare
)) return -2;
48 /* For every two steps the hare takes, the tortoise takes one. */
49 tortoise
= SCM_CDR(tortoise
);
51 while (! SCM_EQ_P (hare
, tortoise
));
53 /* If the tortoise ever catches the hare, then the list must contain
58 /* Typechecking for multi-argument MAP and FOR-EACH.
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. */
64 check_map_args (SCM argv
,
71 SCM
const *ve
= SCM_VELTS (argv
);
74 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
78 if (!(SCM_NULLP (ve
[i
]) || SCM_CONSP (ve
[i
])))
82 scm_apply_generic (gf
, scm_cons (proc
, args
));
84 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
87 elt_len
= srfi1_ilength (ve
[i
]);
91 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
98 scm_remember_upto_here_1 (argv
);
103 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
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'.
113 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
114 #define FUNC_NAME s_srfi1_map
119 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
121 len
= srfi1_ilength (arg1
);
122 SCM_GASSERTn ((SCM_NULLP (arg1
) || SCM_CONSP (arg1
)) && len
>= -1,
124 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
125 SCM_VALIDATE_REST_ARGUMENT (args
);
126 if (SCM_NULLP (args
))
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
))
133 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
134 pres
= SCM_CDRLOC (*pres
);
135 arg1
= SCM_CDR (arg1
);
139 if (SCM_NULLP (SCM_CDR (args
)))
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
))
148 SCM_GASSERTn ((SCM_NULLP (arg2
) || SCM_CONSP (arg2
))
149 && len
>= 0 && len2
>= -1,
151 scm_cons2 (proc
, arg1
, args
),
152 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
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
);
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
);
170 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
172 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
173 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
175 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
176 pres
= SCM_CDRLOC (*pres
);
183 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
185 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
188 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
189 #define FUNC_NAME s_srfi1_for_each
191 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
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
))
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
))
207 call (proc
, SCM_CAR (arg1
));
208 arg1
= SCM_CDR (arg1
);
210 return SCM_UNSPECIFIED
;
212 if (SCM_NULLP (SCM_CDR (args
)))
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
))
221 SCM_GASSERTn ((SCM_NULLP (arg2
) || SCM_CONSP (arg2
))
222 && len
>= 0 && len2
>= -1,
224 scm_cons2 (proc
, arg1
, args
),
225 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
229 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
230 arg1
= SCM_CDR (arg1
);
231 arg2
= SCM_CDR (arg2
);
234 return SCM_UNSPECIFIED
;
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
,
243 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
245 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
246 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
248 scm_apply (proc
, arg1
, SCM_EOL
);
251 return SCM_UNSPECIFIED
;
257 equal_trampoline (SCM proc
, SCM arg1
, SCM arg2
)
259 return scm_equal_p (arg1
, arg2
);
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"
265 "@var{equal?} to @var{x} where the sublists of @var{lst} are\n"
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"
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")
272 #define FUNC_NAME s_scm_srfi1_member
274 scm_t_trampoline_2 equal_p
;
275 SCM_VALIDATE_LIST (2, lst
);
276 if (SCM_UNBNDP (pred
))
277 equal_p
= equal_trampoline
;
280 equal_p
= scm_trampoline_2 (pred
);
281 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
283 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
285 if (!SCM_FALSEP (equal_p (pred
, SCM_CAR (lst
), x
)))
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
300 scm_t_trampoline_2 equal_p
;
301 if (SCM_UNBNDP (pred
))
302 equal_p
= equal_trampoline
;
305 equal_p
= scm_trampoline_2 (pred
);
306 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
308 for(; SCM_CONSP (ls
); ls
= SCM_CDR (ls
))
310 SCM tmp
= SCM_CAR (ls
);
311 SCM_ASSERT_TYPE (SCM_CONSP (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
313 if (SCM_NFALSEP (equal_p (pred
, SCM_CAR (tmp
), key
)))
316 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
323 scm_init_srfi_1 (void)
325 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
326 #ifndef SCM_MAGIC_SNARFER
327 #include "srfi/srfi-1.x"
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")));
337 /* End of srfi-1.c. */