← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/list.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/list.c
 
1
/*===========================================================================
 
2
 *  FileName : list.c
 
3
 *  About    : R5SR pairs and lists
 
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
 
 
59
/*=======================================
 
60
  File Local Function Declarations
 
61
=======================================*/
 
62
static ScmObj list_tail(ScmObj lst, scm_int_t k);
 
63
 
 
64
/*=======================================
 
65
  Function Implementations
 
66
=======================================*/
 
67
/*===========================================================================
 
68
  R5RS : 6.3 Other data types : 6.3.2 Pairs and lists
 
69
===========================================================================*/
 
70
ScmObj
 
71
scm_p_car(ScmObj obj)
 
72
{
 
73
    DECLARE_FUNCTION("car", procedure_fixed_1);
 
74
#if SCM_COMPAT_SIOD_BUGS
 
75
    if (NULLP(obj))
 
76
        return SCM_NULL;
 
77
#endif
 
78
 
 
79
    ENSURE_CONS(obj);
 
80
 
 
81
    return CAR(obj);
 
82
}
 
83
 
 
84
ScmObj
 
85
scm_p_cdr(ScmObj obj)
 
86
{
 
87
    DECLARE_FUNCTION("cdr", procedure_fixed_1);
 
88
#if SCM_COMPAT_SIOD_BUGS
 
89
    if (NULLP(obj))
 
90
        return SCM_NULL;
 
91
#endif
 
92
 
 
93
    ENSURE_CONS(obj);
 
94
 
 
95
    return CDR(obj);
 
96
}
 
97
 
 
98
ScmObj
 
99
scm_p_pairp(ScmObj obj)
 
100
{
 
101
    DECLARE_FUNCTION("pair?", procedure_fixed_1);
 
102
 
 
103
    return MAKE_BOOL(CONSP(obj));
 
104
}
 
105
 
 
106
ScmObj
 
107
scm_p_cons(ScmObj car, ScmObj cdr)
 
108
{
 
109
    DECLARE_FUNCTION("cons", procedure_fixed_2);
 
110
 
 
111
    return CONS(car, cdr);
 
112
}
 
113
 
 
114
ScmObj
 
115
scm_p_set_card(ScmObj pair, ScmObj car)
 
116
{
 
117
    DECLARE_FUNCTION("set-car!", procedure_fixed_2);
 
118
 
 
119
    ENSURE_CONS(pair);
 
120
    ENSURE_MUTABLE_CONS(pair);
 
121
 
 
122
    SET_CAR(pair, car);
 
123
 
 
124
#if SCM_COMPAT_SIOD
 
125
    return car;
 
126
#else
 
127
    return SCM_UNDEF;
 
128
#endif
 
129
}
 
130
 
 
131
ScmObj
 
132
scm_p_set_cdrd(ScmObj pair, ScmObj cdr)
 
133
{
 
134
    DECLARE_FUNCTION("set-cdr!", procedure_fixed_2);
 
135
 
 
136
    ENSURE_CONS(pair);
 
137
    ENSURE_MUTABLE_CONS(pair);
 
138
 
 
139
    SET_CDR(pair, cdr);
 
140
 
 
141
#if SCM_COMPAT_SIOD
 
142
    return cdr;
 
143
#else
 
144
    return SCM_UNDEF;
 
145
#endif
 
146
}
 
147
 
 
148
ScmObj
 
149
scm_p_caar(ScmObj lst)
 
150
{
 
151
    DECLARE_FUNCTION("caar", procedure_fixed_1);
 
152
 
 
153
    return scm_p_car( scm_p_car(lst) );
 
154
}
 
155
 
 
156
ScmObj
 
157
scm_p_cadr(ScmObj lst)
 
158
{
 
159
    DECLARE_FUNCTION("cadr", procedure_fixed_1);
 
160
 
 
161
    return scm_p_car( scm_p_cdr(lst) );
 
162
}
 
163
 
 
164
ScmObj
 
165
scm_p_cdar(ScmObj lst)
 
166
{
 
167
    DECLARE_FUNCTION("cdar", procedure_fixed_1);
 
168
 
 
169
    return scm_p_cdr( scm_p_car(lst) );
 
170
}
 
171
 
 
172
ScmObj
 
173
scm_p_cddr(ScmObj lst)
 
174
{
 
175
    DECLARE_FUNCTION("cddr", procedure_fixed_1);
 
176
 
 
177
    return scm_p_cdr( scm_p_cdr(lst) );
 
178
}
 
179
 
 
180
ScmObj
 
181
scm_p_caddr(ScmObj lst)
 
182
{
 
183
    DECLARE_FUNCTION("caddr", procedure_fixed_1);
 
184
 
 
185
    return scm_p_car( scm_p_cdr( scm_p_cdr(lst) ));
 
186
}
 
187
 
 
188
ScmObj
 
189
scm_p_cdddr(ScmObj lst)
 
190
{
 
191
    DECLARE_FUNCTION("cdddr", procedure_fixed_1);
 
192
 
 
193
    return scm_p_cdr( scm_p_cdr( scm_p_cdr(lst) ));
 
194
}
 
195
 
 
196
ScmObj
 
197
scm_p_list(ScmObj args)
 
198
{
 
199
    DECLARE_FUNCTION("list", procedure_variadic_0);
 
200
 
 
201
    return args;
 
202
}
 
203
 
 
204
ScmObj
 
205
scm_p_nullp(ScmObj obj)
 
206
{
 
207
    DECLARE_FUNCTION("null?", procedure_fixed_1);
 
208
 
 
209
    return MAKE_BOOL(NULLP(obj));
 
210
}
 
211
 
 
212
ScmObj
 
213
scm_p_listp(ScmObj obj)
 
214
{
 
215
    DECLARE_FUNCTION("list?", procedure_fixed_1);
 
216
 
 
217
    /* fast path */
 
218
    if (NULLP(obj))
 
219
        return SCM_TRUE;
 
220
    if (!CONSP(obj))
 
221
        return SCM_FALSE;
 
222
 
 
223
    return MAKE_BOOL(PROPER_LISTP(obj));
 
224
}
 
225
 
 
226
#define TERMINATOR_LEN 1
 
227
 
 
228
/* scm_length() for non-circular list */
 
229
scm_int_t
 
230
scm_finite_length(ScmObj lst)
 
231
{
 
232
    scm_int_t len;
 
233
 
 
234
    for (len = 0; CONSP(lst); lst = CDR(lst))
 
235
        len++;
 
236
 
 
237
    if (NULLP(lst))
 
238
        return len;
 
239
    else
 
240
        return SCM_LISTLEN_ENCODE_DOTTED(len + TERMINATOR_LEN);
 
241
}
 
242
 
 
243
/*
 
244
 * Notice
 
245
 *
 
246
 * This function is ported from Gauche, by Shiro Kawai(shiro@acm.org)
 
247
 */
 
248
/* FIXME: Insert its copyright and license into this file properly */
 
249
/*
 
250
 * ChangeLog:
 
251
 *
 
252
 * 2006-01-05 YamaKen  Return dot list length and circular indication.
 
253
 *
 
254
 */
 
255
/* Returns -1 as one length improper list for non-list obj. */
 
256
scm_int_t
 
257
scm_length(ScmObj lst)
 
258
{
 
259
    ScmObj slow;
 
260
    scm_int_t proper_len;
 
261
 
 
262
    for (proper_len = 0, slow = lst;;) {
 
263
        if (NULLP(lst)) break;
 
264
        if (!CONSP(lst))
 
265
            return SCM_LISTLEN_ENCODE_DOTTED(proper_len + TERMINATOR_LEN);
 
266
        if (proper_len != 0 && lst == slow)
 
267
            return SCM_LISTLEN_ENCODE_CIRCULAR(proper_len);
 
268
 
 
269
        lst = CDR(lst);
 
270
        proper_len++;
 
271
        if (NULLP(lst)) break;
 
272
        if (!CONSP(lst))
 
273
            return SCM_LISTLEN_ENCODE_DOTTED(proper_len + TERMINATOR_LEN);
 
274
        if (lst == slow)
 
275
            return SCM_LISTLEN_ENCODE_CIRCULAR(proper_len);
 
276
 
 
277
        lst = CDR(lst);
 
278
        slow = CDR(slow);
 
279
        proper_len++;
 
280
    }
 
281
 
 
282
    return proper_len;
 
283
}
 
284
 
 
285
#undef TERMINATOR_LEN
 
286
 
 
287
ScmObj
 
288
scm_p_length(ScmObj obj)
 
289
{
 
290
    scm_int_t len;
 
291
    DECLARE_FUNCTION("length", procedure_fixed_1);
 
292
 
 
293
    len = scm_length(obj);
 
294
    if (!SCM_LISTLEN_PROPERP(len))
 
295
        ERR_OBJ("proper list required but got", obj);
 
296
 
 
297
    return MAKE_INT(len);
 
298
}
 
299
 
 
300
ScmObj
 
301
scm_p_append(ScmObj args)
 
302
{
 
303
    ScmQueue q;
 
304
    ScmObj lst, elm, ret;
 
305
    DECLARE_FUNCTION("append", procedure_variadic_0);
 
306
 
 
307
    if (NULLP(args))
 
308
        return SCM_NULL;
 
309
 
 
310
    ret = SCM_NULL;
 
311
    SCM_QUEUE_POINT_TO(q, ret);
 
312
    /* duplicate and merge all but the last argument */
 
313
    FOR_EACH_BUTLAST (lst, args) {
 
314
        FOR_EACH (elm, lst)
 
315
            SCM_QUEUE_ADD(q, elm);
 
316
        ENSURE_PROPER_LIST_TERMINATION(lst, args);
 
317
    }
 
318
    /* append the last argument */
 
319
    SCM_QUEUE_SLOPPY_APPEND(q, lst);
 
320
 
 
321
    return ret;
 
322
}
 
323
 
 
324
ScmObj
 
325
scm_p_reverse(ScmObj lst)
 
326
{
 
327
    ScmObj ret, elm;
 
328
    DECLARE_FUNCTION("reverse", procedure_fixed_1);
 
329
 
 
330
    ret = SCM_NULL;
 
331
    FOR_EACH (elm, lst)
 
332
        ret = CONS(elm, ret);
 
333
 
 
334
    return ret;
 
335
}
 
336
 
 
337
static ScmObj
 
338
list_tail(ScmObj lst, scm_int_t k)
 
339
{
 
340
    while (k--) {
 
341
        if (!CONSP(lst))
 
342
            return SCM_INVALID;
 
343
        lst = CDR(lst);
 
344
    }
 
345
 
 
346
    return lst;
 
347
}
 
348
 
 
349
ScmObj
 
350
scm_p_list_tail(ScmObj lst, ScmObj k)
 
351
{
 
352
    ScmObj ret;
 
353
    DECLARE_FUNCTION("list-tail", procedure_fixed_2);
 
354
 
 
355
    ENSURE_INT(k);
 
356
 
 
357
    ret = list_tail(lst, SCM_INT_VALUE(k));
 
358
    if (!VALIDP(ret))
 
359
        ERR_OBJ("out of range or invalid list", LIST_2(lst, k));
 
360
 
 
361
    return ret;
 
362
}
 
363
 
 
364
ScmObj
 
365
scm_p_list_ref(ScmObj lst, ScmObj k)
 
366
{
 
367
    ScmObj tail;
 
368
    DECLARE_FUNCTION("list-ref", procedure_fixed_2);
 
369
 
 
370
    ENSURE_INT(k);
 
371
 
 
372
    tail = list_tail(lst, SCM_INT_VALUE(k));
 
373
    if (!VALIDP(tail) || NULLP(tail))
 
374
        ERR_OBJ("out of range or invalid list", LIST_2(lst, k));
 
375
 
 
376
    return CAR(tail);
 
377
}
 
378
 
 
379
#define MEMBER_BODY(obj, lst, cmp)                                           \
 
380
    do {                                                                     \
 
381
        for (; CONSP(lst); lst = CDR(lst))                                   \
 
382
            if (cmp(obj, CAR(lst)))                                          \
 
383
                return lst;                                                  \
 
384
        CHECK_PROPER_LIST_TERMINATION(lst, lst);                             \
 
385
        return SCM_FALSE;                                                    \
 
386
    } while (/* CONSTCOND */ 0)
 
387
 
 
388
ScmObj
 
389
scm_p_memq(ScmObj obj, ScmObj lst)
 
390
{
 
391
    DECLARE_FUNCTION("memq", procedure_fixed_2);
 
392
 
 
393
    MEMBER_BODY(obj, lst, EQ);
 
394
}
 
395
 
 
396
ScmObj
 
397
scm_p_memv(ScmObj obj, ScmObj lst)
 
398
{
 
399
    DECLARE_FUNCTION("memv", procedure_fixed_2);
 
400
 
 
401
#if (SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)
 
402
    MEMBER_BODY(obj, lst, EQ);
 
403
#else
 
404
    MEMBER_BODY(obj, lst, EQVP);
 
405
#endif
 
406
}
 
407
 
 
408
ScmObj
 
409
scm_p_member(ScmObj obj, ScmObj lst)
 
410
{
 
411
    DECLARE_FUNCTION("member", procedure_fixed_2);
 
412
 
 
413
    MEMBER_BODY(obj, lst, EQUALP);
 
414
}
 
415
 
 
416
#undef MEMBER_BODY
 
417
 
 
418
#define ASSOC_BODY(obj, alist, cmp)                                          \
 
419
    do {                                                                     \
 
420
        ScmObj pair, key;                                                    \
 
421
                                                                             \
 
422
        FOR_EACH (pair, alist) {                                             \
 
423
            ENSURE_CONS(pair);                                               \
 
424
            key = CAR(pair);                                                 \
 
425
            if (cmp(key, obj))                                               \
 
426
                return pair;                                                 \
 
427
        }                                                                    \
 
428
        CHECK_PROPER_LIST_TERMINATION(alist, alist);                         \
 
429
        return SCM_FALSE;                                                    \
 
430
    } while (/* CONSTCOND */ 0)
 
431
 
 
432
ScmObj
 
433
scm_p_assq(ScmObj obj, ScmObj alist)
 
434
{
 
435
    DECLARE_FUNCTION("assq", procedure_fixed_2);
 
436
 
 
437
    ASSOC_BODY(obj, alist, EQ);
 
438
}
 
439
 
 
440
ScmObj
 
441
scm_p_assv(ScmObj obj, ScmObj alist)
 
442
{
 
443
    DECLARE_FUNCTION("assv", procedure_fixed_2);
 
444
 
 
445
#if (SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)
 
446
    ASSOC_BODY(obj, alist, EQ);
 
447
#else
 
448
    ASSOC_BODY(obj, alist, EQVP);
 
449
#endif
 
450
}
 
451
 
 
452
ScmObj
 
453
scm_p_assoc(ScmObj obj, ScmObj alist)
 
454
{
 
455
    DECLARE_FUNCTION("assoc", procedure_fixed_2);
 
456
 
 
457
    ASSOC_BODY(obj, alist, EQUALP);
 
458
}
 
459
 
 
460
#undef ASSOC_BODY