← Back to branch summary

~ubuntu-branches/ubuntu/hardy/sigscheme/hardy-proposed

« back to all changes in this revision

Viewing changes to src/procedure.c

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2006-05-23 21:46:41 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20060523214641-6ix4gz34wpiehub8
Tags: 0.5.0-2
http://bugs.debian.org/368571
* debian/control (Build-Depends): Added ruby.
  Thanks to Frederik Schueler.  Closes: #368571
* debian/rules (clean): invoke 'distclean' instead of 'clean'.

Show diffs side-by-side

added added

removed removed

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