1 /*===========================================================================
2 * Filename : procedure.c
3 * About : Miscellaneous R5RS procedures
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include "sigscheme.h"
41 #include "sigschemeinternal.h"
42
43 /*=======================================
44 File Local Macro Definitions
45 =======================================*/
46 #define ERRMSG_UNEVEN_MAP_ARGS "unequal-length lists are passed as arguments"
47
48 /*=======================================
49 File Local Type Definitions
50 =======================================*/
51
52 /*=======================================
53 Variable Definitions
54 =======================================*/
55 /* canonical internal encoding for identifiers */
56 SCM_DEFINE_EXPORTED_VARS(procedure);
57
58 /*=======================================
59 File Local Function Declarations
60 =======================================*/
61
62 /*=======================================
63 Function Definitions
64 =======================================*/
65 /*===========================================================================
66 R5RS : 6.1 Equivalence predicates
67 ===========================================================================*/
68 SCM_EXPORT ScmObj
scm_p_eqp(ScmObj obj1,ScmObj obj2)69 scm_p_eqp(ScmObj obj1, ScmObj obj2)
70 {
71 DECLARE_FUNCTION("eq?", procedure_fixed_2);
72
73 return MAKE_BOOL(EQ(obj1, obj2));
74 }
75
76 SCM_EXPORT ScmObj
scm_p_eqvp(ScmObj obj1,ScmObj obj2)77 scm_p_eqvp(ScmObj obj1, ScmObj obj2)
78 {
79 #if SCM_HAS_EQVP
80
81 #define scm_p_eqvp error_eqvp_recursed__ /* Safety measure. */
82 return EQVP(obj1, obj2);
83 #undef scm_p_eqvp
84
85 #else /* don't have inlined EQVP() */
86
87 #if (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY))
88 enum ScmObjType type;
89 #endif
90 DECLARE_FUNCTION("eqv?", procedure_fixed_2);
91
92 if (EQ(obj1, obj2))
93 return SCM_TRUE;
94
95 #if (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY))
96 type = SCM_TYPE(obj1);
97
98 /* different type */
99 if (type != SCM_TYPE(obj2))
100 return SCM_FALSE;
101
102 /* same type */
103 switch (type) {
104 #if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
105 case ScmInt:
106 return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
107 #endif
108
109 #if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
110 case ScmChar:
111 return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
112 #endif
113
114 default:
115 break;
116 }
117 #endif /* (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)) */
118
119 return SCM_FALSE;
120
121 #endif /* don't have inlined EQVP() */
122 }
123
124 SCM_EXPORT ScmObj
scm_p_equalp(ScmObj obj1,ScmObj obj2)125 scm_p_equalp(ScmObj obj1, ScmObj obj2)
126 {
127 enum ScmObjType type;
128 ScmObj elm1, elm2;
129 #if SCM_USE_VECTOR
130 ScmObj *v1, *v2;
131 scm_int_t i, len;
132 #endif
133 DECLARE_FUNCTION("equal?", procedure_fixed_2);
134
135 if (EQ(obj1, obj2))
136 return SCM_TRUE;
137
138 type = SCM_TYPE(obj1);
139
140 /* different type */
141 if (type != SCM_TYPE(obj2))
142 return SCM_FALSE;
143
144 /* same type */
145 switch (type) {
146 #if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
147 case ScmInt:
148 return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
149 #endif
150
151 #if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
152 case ScmChar:
153 return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
154 #endif
155
156 #if SCM_USE_STRING
157 case ScmString:
158 return MAKE_BOOL(STRING_EQUALP(obj1, obj2));
159 #endif
160
161 case ScmCons:
162 for (; CONSP(obj1) && CONSP(obj2); obj1 = CDR(obj1), obj2 = CDR(obj2))
163 {
164 elm1 = CAR(obj1);
165 elm2 = CAR(obj2);
166 if (!EQ(elm1, elm2)
167 && (SCM_TYPE(elm1) != SCM_TYPE(elm2)
168 || !EQUALP(elm1, elm2)))
169 return SCM_FALSE;
170 }
171 /* compare last cdr */
172 return (EQ(obj1, obj2)) ? SCM_TRUE : scm_p_equalp(obj1, obj2);
173
174 #if SCM_USE_VECTOR
175 case ScmVector:
176 len = SCM_VECTOR_LEN(obj1);
177 if (len != SCM_VECTOR_LEN(obj2))
178 return SCM_FALSE;
179
180 v1 = SCM_VECTOR_VEC(obj1);
181 v2 = SCM_VECTOR_VEC(obj2);
182 for (i = 0; i < len; i++) {
183 elm1 = v1[i];
184 elm2 = v2[i];
185 if (!EQ(elm1, elm2)
186 && (SCM_TYPE(elm1) != SCM_TYPE(elm2)
187 || !EQUALP(elm1, elm2)))
188 return SCM_FALSE;
189 }
190 return SCM_TRUE;
191 #endif
192
193 #if SCM_USE_SSCM_EXTENSIONS
194 case ScmCPointer:
195 return MAKE_BOOL(SCM_C_POINTER_VALUE(obj1)
196 == SCM_C_POINTER_VALUE(obj2));
197
198 case ScmCFuncPointer:
199 return MAKE_BOOL(SCM_C_FUNCPOINTER_VALUE(obj1)
200 == SCM_C_FUNCPOINTER_VALUE(obj2));
201 #endif
202
203 default:
204 break;
205 }
206
207 return SCM_FALSE;
208 }
209
210 /*===================================
211 R5RS : 6.3 Other data types
212 ===================================*/
213 /*===========================================================================
214 R5RS : 6.3 Other data types : 6.3.1 Booleans
215 ===========================================================================*/
216 SCM_EXPORT ScmObj
scm_p_not(ScmObj obj)217 scm_p_not(ScmObj obj)
218 {
219 DECLARE_FUNCTION("not", procedure_fixed_1);
220
221 return MAKE_BOOL(FALSEP(obj));
222 }
223
224 SCM_EXPORT ScmObj
scm_p_booleanp(ScmObj obj)225 scm_p_booleanp(ScmObj obj)
226 {
227 DECLARE_FUNCTION("boolean?", procedure_fixed_1);
228
229 return MAKE_BOOL(EQ(obj, SCM_FALSE) || EQ(obj, SCM_TRUE));
230 }
231
232 /*===========================================================================
233 R5RS : 6.3 Other data types : 6.3.3 Symbols
234 ===========================================================================*/
235 SCM_EXPORT ScmObj
scm_p_symbolp(ScmObj obj)236 scm_p_symbolp(ScmObj obj)
237 {
238 DECLARE_FUNCTION("symbol?", procedure_fixed_1);
239
240 return MAKE_BOOL(SYMBOLP(obj));
241 }
242
243 SCM_EXPORT ScmObj
scm_p_symbol2string(ScmObj sym)244 scm_p_symbol2string(ScmObj sym)
245 {
246 DECLARE_FUNCTION("symbol->string", procedure_fixed_1);
247
248 ENSURE_SYMBOL(sym);
249
250 return CONST_STRING(SCM_SYMBOL_NAME(sym));
251 }
252
253 SCM_EXPORT ScmObj
scm_p_string2symbol(ScmObj str)254 scm_p_string2symbol(ScmObj str)
255 {
256 DECLARE_FUNCTION("string->symbol", procedure_fixed_1);
257
258 ENSURE_STRING(str);
259
260 return scm_intern(SCM_STRING_STR(str));
261 }
262
263 /*=======================================
264 R5RS : 6.4 Control Features
265 =======================================*/
266 SCM_EXPORT ScmObj
scm_p_procedurep(ScmObj obj)267 scm_p_procedurep(ScmObj obj)
268 {
269 DECLARE_FUNCTION("procedure?", procedure_fixed_1);
270
271 return MAKE_BOOL(PROCEDUREP(obj));
272 }
273
274 SCM_EXPORT ScmObj
scm_p_map(ScmObj proc,ScmObj args)275 scm_p_map(ScmObj proc, ScmObj args)
276 {
277 DECLARE_FUNCTION("map", procedure_variadic_1);
278
279 if (NULLP(args))
280 ERR("wrong number of arguments");
281
282 /* fast path for single arg case */
283 if (NULLP(CDR(args)))
284 return scm_map_single_arg(proc, CAR(args));
285
286 /* multiple args case */
287 return scm_map_multiple_args(proc, args, scm_false);
288 }
289
290 SCM_EXPORT ScmObj
scm_map_single_arg(ScmObj proc,ScmObj lst)291 scm_map_single_arg(ScmObj proc, ScmObj lst)
292 {
293 ScmQueue q;
294 ScmObj elm, ret;
295 DECLARE_INTERNAL_FUNCTION("map");
296
297 ret = SCM_NULL;
298 SCM_QUEUE_POINT_TO(q, ret);
299 FOR_EACH (elm, lst) {
300 elm = scm_call(proc, LIST_1(elm));
301 SCM_QUEUE_ADD(q, elm);
302 }
303 NO_MORE_ARG(lst);
304
305 return ret;
306 }
307
308 SCM_EXPORT ScmObj
scm_map_multiple_args(ScmObj proc,ScmObj lsts,scm_bool allow_uneven_lists)309 scm_map_multiple_args(ScmObj proc, ScmObj lsts, scm_bool allow_uneven_lists)
310 {
311 ScmQueue retq, argq;
312 ScmObj ret, elm, map_args, rest_lsts, lst;
313 DECLARE_INTERNAL_FUNCTION("map");
314
315 ret = SCM_NULL;
316 SCM_QUEUE_POINT_TO(retq, ret);
317 for (;;) {
318 /* slice args */
319 map_args = SCM_NULL;
320 SCM_QUEUE_POINT_TO(argq, map_args);
321 for (rest_lsts = lsts; CONSP(rest_lsts); rest_lsts = CDR(rest_lsts)) {
322 lst = CAR(rest_lsts);
323 if (CONSP(lst))
324 SCM_QUEUE_ADD(argq, CAR(lst));
325 else if (NULLP(lst))
326 goto finish;
327 else
328 ERR_OBJ("invalid argument", lst);
329 /* pop destructively */
330 SET_CAR(rest_lsts, CDR(lst));
331 }
332
333 elm = scm_call(proc, map_args);
334 SCM_QUEUE_ADD(retq, elm);
335 }
336
337 finish:
338 #if SCM_STRICT_ARGCHECK
339 if (!allow_uneven_lists) {
340 /* R5RS: 6.4 Control features
341 * > If more than one list is given, then they must all be the same
342 * length. SigScheme rejects such user-error explicitly. */
343 if (!EQ(lsts, rest_lsts))
344 ERR(ERRMSG_UNEVEN_MAP_ARGS);
345 FOR_EACH (lst, lsts) {
346 if (!NULLP(lst))
347 ERR(ERRMSG_UNEVEN_MAP_ARGS);
348 }
349 NO_MORE_ARG(lsts);
350 }
351 #endif
352
353 return ret;
354 }
355
356 SCM_EXPORT ScmObj
scm_p_for_each(ScmObj proc,ScmObj args)357 scm_p_for_each(ScmObj proc, ScmObj args)
358 {
359 DECLARE_FUNCTION("for-each", procedure_variadic_1);
360
361 scm_p_map(proc, args);
362
363 return SCM_UNDEF;
364 }
365
366 #if SCM_USE_CONTINUATION
367 SCM_EXPORT ScmObj
scm_p_call_with_current_continuation(ScmObj proc,ScmEvalState * eval_state)368 scm_p_call_with_current_continuation(ScmObj proc, ScmEvalState *eval_state)
369 {
370 DECLARE_FUNCTION("call-with-current-continuation",
371 procedure_fixed_tailrec_1);
372
373 return scm_call_with_current_continuation(proc, eval_state);
374 }
375 #endif /* SCM_USE_CONTINUATION */
376
377 SCM_EXPORT ScmObj
scm_p_values(ScmObj args)378 scm_p_values(ScmObj args)
379 {
380 DECLARE_FUNCTION("values", procedure_variadic_0);
381
382 /* Values with one arg must return something that fits an ordinary
383 * continuation. */
384 if (LIST_1_P(args))
385 return CAR(args);
386
387 /* Otherwise, we'll return the values in a packet. */
388 return SCM_MAKE_VALUEPACKET(args);
389 }
390
391 SCM_EXPORT ScmObj
scm_p_call_with_values(ScmObj producer,ScmObj consumer,ScmEvalState * eval_state)392 scm_p_call_with_values(ScmObj producer, ScmObj consumer,
393 ScmEvalState *eval_state)
394 {
395 ScmObj vals;
396 DECLARE_FUNCTION("call-with-values", procedure_fixed_tailrec_2);
397
398 vals = scm_call(producer, SCM_NULL);
399
400 return LIST_3(scm_values_applier, consumer, vals);
401 }
402
403 #if SCM_USE_CONTINUATION
404 SCM_EXPORT ScmObj
scm_p_dynamic_wind(ScmObj before,ScmObj thunk,ScmObj after)405 scm_p_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after)
406 {
407 DECLARE_FUNCTION("dynamic-wind", procedure_fixed_3);
408
409 /* To reject non-procedure arguments before evaluating any other
410 * arguments, ensure the types here instead of call(). */
411 ENSURE_PROCEDURE(before);
412 ENSURE_PROCEDURE(thunk);
413 ENSURE_PROCEDURE(after);
414
415 return scm_dynamic_wind(before, thunk, after);
416 }
417 #endif /* SCM_USE_CONTINUATION */
418