1
/*===========================================================================
2
* Filename : procedure.c
3
* About : Miscellaneous R5RS procedures
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 SigScheme Project <uim AT freedesktop.org>
10
* All rights reserved.
12
* Redistribution and use in source and binary forms, with or without
13
* modification, are permitted provided that the following conditions
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.
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
===========================================================================*/
40
#include "sigscheme.h"
41
#include "sigschemeinternal.h"
43
/*=======================================
44
File Local Macro Definitions
45
=======================================*/
46
#define ERRMSG_UNEVEN_MAP_ARGS "uneven-length lists are passed as arguments"
48
/*=======================================
49
File Local Type Definitions
50
=======================================*/
52
/*=======================================
54
=======================================*/
55
/* canonical internal encoding for identifiers */
56
SCM_DEFINE_EXPORTED_VARS(procedure);
58
/*=======================================
59
File Local Function Declarations
60
=======================================*/
61
static ScmObj map_single_arg(ScmObj proc, ScmObj lst);
62
static ScmObj map_multiple_args(ScmObj proc, ScmObj lsts);
64
/*=======================================
66
=======================================*/
67
/*===========================================================================
68
R5RS : 6.1 Equivalence predicates
69
===========================================================================*/
71
scm_p_eqp(ScmObj obj1, ScmObj obj2)
73
DECLARE_FUNCTION("eq?", procedure_fixed_2);
75
return MAKE_BOOL(EQ(obj1, obj2));
79
scm_p_eqvp(ScmObj obj1, ScmObj obj2)
83
#define scm_p_eqvp error_eqvp_recursed__ /* Safety measure. */
84
return EQVP(obj1, obj2);
87
#else /* don't have inlined EQVP() */
89
#if (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY))
92
DECLARE_FUNCTION("eqv?", procedure_fixed_2);
97
#if (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY))
98
type = SCM_TYPE(obj1);
101
if (type != SCM_TYPE(obj2))
106
#if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
108
return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
111
#if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
113
return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
119
#endif /* (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)) */
123
#endif /* don't have inlined EQVP() */
127
scm_p_equalp(ScmObj obj1, ScmObj obj2)
129
enum ScmObjType type;
135
DECLARE_FUNCTION("equal?", procedure_fixed_2);
140
type = SCM_TYPE(obj1);
143
if (type != SCM_TYPE(obj2))
148
#if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
150
return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
153
#if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
155
return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
160
return MAKE_BOOL(STRING_EQUALP(obj1, obj2));
164
for (; CONSP(obj1) && CONSP(obj2); obj1 = CDR(obj1), obj2 = CDR(obj2))
169
&& (SCM_TYPE(elm1) != SCM_TYPE(elm2)
170
|| !EQUALP(elm1, elm2)))
173
/* compare last cdr */
174
return (EQ(obj1, obj2)) ? SCM_TRUE : scm_p_equalp(obj1, obj2);
178
len = SCM_VECTOR_LEN(obj1);
179
if (len != SCM_VECTOR_LEN(obj2))
182
v1 = SCM_VECTOR_VEC(obj1);
183
v2 = SCM_VECTOR_VEC(obj2);
184
for (i = 0; i < len; i++) {
188
&& (SCM_TYPE(elm1) != SCM_TYPE(elm2)
189
|| !EQUALP(elm1, elm2)))
195
#if SCM_USE_SSCM_EXTENSIONS
197
return MAKE_BOOL(SCM_C_POINTER_VALUE(obj1)
198
== SCM_C_POINTER_VALUE(obj2));
200
case ScmCFuncPointer:
201
return MAKE_BOOL(SCM_C_FUNCPOINTER_VALUE(obj1)
202
== SCM_C_FUNCPOINTER_VALUE(obj2));
212
/*===================================
213
R5RS : 6.3 Other data types
214
===================================*/
215
/*===========================================================================
216
R5RS : 6.3 Other data types : 6.3.1 Booleans
217
===========================================================================*/
219
scm_p_not(ScmObj obj)
221
DECLARE_FUNCTION("not", procedure_fixed_1);
223
return MAKE_BOOL(FALSEP(obj));
227
scm_p_booleanp(ScmObj obj)
229
DECLARE_FUNCTION("boolean?", procedure_fixed_1);
231
return MAKE_BOOL(EQ(obj, SCM_FALSE) || EQ(obj, SCM_TRUE));
234
/*===========================================================================
235
R5RS : 6.3 Other data types : 6.3.3 Symbols
236
===========================================================================*/
238
scm_p_symbolp(ScmObj obj)
240
DECLARE_FUNCTION("symbol?", procedure_fixed_1);
242
return MAKE_BOOL(SYMBOLP(obj));
246
scm_p_symbol2string(ScmObj sym)
248
DECLARE_FUNCTION("symbol->string", procedure_fixed_1);
252
return CONST_STRING(SCM_SYMBOL_NAME(sym));
256
scm_p_string2symbol(ScmObj str)
258
DECLARE_FUNCTION("string->symbol", procedure_fixed_1);
262
return scm_intern(SCM_STRING_STR(str));
265
/*=======================================
266
R5RS : 6.4 Control Features
267
=======================================*/
269
scm_p_procedurep(ScmObj obj)
271
DECLARE_FUNCTION("procedure?", procedure_fixed_1);
273
return MAKE_BOOL(PROCEDUREP(obj));
277
scm_p_map(ScmObj proc, ScmObj args)
279
DECLARE_FUNCTION("map", procedure_variadic_1);
282
ERR("wrong number of arguments");
284
/* fast path for single arg case */
285
if (NULLP(CDR(args)))
286
return map_single_arg(proc, CAR(args));
288
/* multiple args case */
289
return map_multiple_args(proc, args);
293
map_single_arg(ScmObj proc, ScmObj lst)
297
DECLARE_INTERNAL_FUNCTION("map");
300
SCM_QUEUE_POINT_TO(q, ret);
301
FOR_EACH (elm, lst) {
302
elm = scm_call(proc, LIST_1(elm));
303
SCM_QUEUE_ADD(q, elm);
311
map_multiple_args(ScmObj proc, ScmObj lsts)
314
ScmObj ret, elm, map_args, rest_lsts, lst;
315
DECLARE_INTERNAL_FUNCTION("map");
318
SCM_QUEUE_POINT_TO(retq, ret);
322
SCM_QUEUE_POINT_TO(argq, map_args);
323
for (rest_lsts = lsts; CONSP(rest_lsts); rest_lsts = CDR(rest_lsts)) {
324
lst = CAR(rest_lsts);
326
SCM_QUEUE_ADD(argq, CAR(lst));
330
ERR_OBJ("invalid argument", lst);
331
/* pop destructively */
332
SET_CAR(rest_lsts, CDR(lst));
335
elm = scm_call(proc, map_args);
336
SCM_QUEUE_ADD(retq, elm);
340
#if SCM_STRICT_ARGCHECK
341
/* R5RS: 6.4 Control features
342
* > If more than one list is given, then they must all be the same length.
343
* SigScheme rejects such user-error explicitly. */
344
if (!EQ(lsts, rest_lsts))
345
ERR(ERRMSG_UNEVEN_MAP_ARGS);
346
FOR_EACH (lst, lsts) {
348
ERR(ERRMSG_UNEVEN_MAP_ARGS);
357
scm_p_for_each(ScmObj proc, ScmObj args)
359
DECLARE_FUNCTION("for-each", procedure_variadic_1);
361
scm_p_map(proc, args);
366
#if SCM_USE_CONTINUATION
368
scm_p_call_with_current_continuation(ScmObj proc, ScmEvalState *eval_state)
370
DECLARE_FUNCTION("call-with-current-continuation",
371
procedure_fixed_tailrec_1);
373
return scm_call_with_current_continuation(proc, eval_state);
375
#endif /* SCM_USE_CONTINUATION */
378
scm_p_values(ScmObj args)
380
DECLARE_FUNCTION("values", procedure_variadic_0);
382
/* Values with one arg must return something that fits an ordinary
387
/* Otherwise, we'll return the values in a packet. */
388
return SCM_MAKE_VALUEPACKET(args);
392
scm_p_call_with_values(ScmObj producer, ScmObj consumer,
393
ScmEvalState *eval_state)
396
DECLARE_FUNCTION("call-with-values", procedure_fixed_tailrec_2);
398
vals = scm_call(producer, SCM_NULL);
400
return LIST_3(scm_values_applier, consumer, vals);
403
#if SCM_USE_CONTINUATION
405
scm_p_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after)
407
DECLARE_FUNCTION("dynamic-wind", procedure_fixed_3);
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);
415
return scm_dynamic_wind(before, thunk, after);
417
#endif /* SCM_USE_CONTINUATION */
added
removed
sigscheme/src/procedure.c
