← 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: 2007-01-29 15:31:24 UTC
  • mfrom: (1.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070129153124-j5fcqyrwcfbczma7
Tags: 0.7.4-1
New upstream release.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/list.c
2
2
 *  Filename : list.c
3
3
 *  About    : R5SR pairs and lists
4
4
 *
5
 
 *  Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
 
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>
6
9
 *
7
10
 *  All rights reserved.
8
11
 *
96
99
  R5RS : 6.3 Other data types : 6.3.2 Pairs and lists
97
100
===========================================================================*/
98
101
SCM_EXPORT ScmObj
 
102
scm_p_pairp(ScmObj obj)
 
103
{
 
104
    DECLARE_FUNCTION("pair?", procedure_fixed_1);
 
105
 
 
106
    return MAKE_BOOL(CONSP(obj));
 
107
}
 
108
 
 
109
SCM_EXPORT ScmObj
 
110
scm_p_cons(ScmObj car, ScmObj cdr)
 
111
{
 
112
    DECLARE_FUNCTION("cons", procedure_fixed_2);
 
113
 
 
114
    return CONS(car, cdr);
 
115
}
 
116
 
 
117
SCM_EXPORT ScmObj
99
118
scm_p_car(ScmObj obj)
100
119
{
101
120
    DECLARE_FUNCTION("car", procedure_fixed_1);
124
143
}
125
144
 
126
145
SCM_EXPORT ScmObj
127
 
scm_p_pairp(ScmObj obj)
128
 
{
129
 
    DECLARE_FUNCTION("pair?", procedure_fixed_1);
130
 
 
131
 
    return MAKE_BOOL(CONSP(obj));
132
 
}
133
 
 
134
 
SCM_EXPORT ScmObj
135
 
scm_p_cons(ScmObj car, ScmObj cdr)
136
 
{
137
 
    DECLARE_FUNCTION("cons", procedure_fixed_2);
138
 
 
139
 
    return CONS(car, cdr);
140
 
}
141
 
 
142
 
SCM_EXPORT ScmObj
143
146
scm_p_set_carx(ScmObj pair, ScmObj car)
144
147
{
145
148
    DECLARE_FUNCTION("set-car!", procedure_fixed_2);
178
181
{
179
182
    DECLARE_FUNCTION("caar", procedure_fixed_1);
180
183
 
181
 
    return scm_p_car( scm_p_car(lst) );
 
184
    return scm_p_car(scm_p_car(lst));
182
185
}
183
186
 
184
187
SCM_EXPORT ScmObj
186
189
{
187
190
    DECLARE_FUNCTION("cadr", procedure_fixed_1);
188
191
 
189
 
    return scm_p_car( scm_p_cdr(lst) );
 
192
    return scm_p_car(scm_p_cdr(lst));
190
193
}
191
194
 
192
195
SCM_EXPORT ScmObj
194
197
{
195
198
    DECLARE_FUNCTION("cdar", procedure_fixed_1);
196
199
 
197
 
    return scm_p_cdr( scm_p_car(lst) );
 
200
    return scm_p_cdr(scm_p_car(lst));
198
201
}
199
202
 
200
203
SCM_EXPORT ScmObj
202
205
{
203
206
    DECLARE_FUNCTION("cddr", procedure_fixed_1);
204
207
 
205
 
    return scm_p_cdr( scm_p_cdr(lst) );
 
208
    return scm_p_cdr(scm_p_cdr(lst));
206
209
}
207
210
 
208
211
SCM_EXPORT ScmObj
210
213
{
211
214
    DECLARE_FUNCTION("caddr", procedure_fixed_1);
212
215
 
213
 
    return scm_p_car( scm_p_cdr( scm_p_cdr(lst) ));
 
216
    return scm_p_car(scm_p_cdr(scm_p_cdr(lst)));
214
217
}
215
218
 
216
219
SCM_EXPORT ScmObj
218
221
{
219
222
    DECLARE_FUNCTION("cdddr", procedure_fixed_1);
220
223
 
221
 
    return scm_p_cdr( scm_p_cdr( scm_p_cdr(lst) ));
222
 
}
223
 
 
224
 
SCM_EXPORT ScmObj
225
 
scm_p_list(ScmObj args)
226
 
{
227
 
    DECLARE_FUNCTION("list", procedure_variadic_0);
228
 
 
229
 
    return args;
 
224
    return scm_p_cdr(scm_p_cdr(scm_p_cdr(lst)));
230
225
}
231
226
 
232
227
SCM_EXPORT ScmObj
251
246
    return MAKE_BOOL(PROPER_LISTP(obj));
252
247
}
253
248
 
254
 
#define TERMINATOR_LEN 1
 
249
SCM_EXPORT ScmObj
 
250
scm_p_list(ScmObj args)
 
251
{
 
252
    DECLARE_FUNCTION("list", procedure_variadic_0);
 
253
 
 
254
    return args;
 
255
}
255
256
 
256
257
/* scm_length() for non-circular list */
257
258
SCM_EXPORT scm_int_t
265
266
    if (NULLP(lst))
266
267
        return len;
267
268
    else
268
 
        return SCM_LISTLEN_ENCODE_DOTTED(len + TERMINATOR_LEN);
 
269
        return SCM_LISTLEN_ENCODE_DOTTED(len);
269
270
}
270
271
 
271
272
/*
273
274
 *
274
275
 * 2005-08-12 kzk      Copied from Scm_Length() of Gauche 0.8.5.
275
276
 * 2006-01-05 YamaKen  Return dotted list length and circular indication.
 
277
 * 2006-10-02 YamaKen  Change dotted list length definition to SRFI-1's.
276
278
 *
277
279
 */
278
280
/* Returns -1 as one length improper list for non-list obj. */
280
282
scm_length(ScmObj lst)
281
283
{
282
284
    ScmObj slow;
283
 
    scm_int_t proper_len;
 
285
    scm_int_t len;
284
286
 
285
 
    for (proper_len = 0, slow = lst;;) {
 
287
    for (len = 0, slow = lst;;) {
286
288
        if (NULLP(lst)) break;
287
289
        if (!CONSP(lst))
288
 
            return SCM_LISTLEN_ENCODE_DOTTED(proper_len + TERMINATOR_LEN);
289
 
        if (proper_len != 0 && lst == slow)
290
 
            return SCM_LISTLEN_ENCODE_CIRCULAR(proper_len);
 
290
            return SCM_LISTLEN_ENCODE_DOTTED(len);
 
291
        if (len != 0 && lst == slow)
 
292
            return SCM_LISTLEN_ENCODE_CIRCULAR(len);
291
293
 
292
294
        lst = CDR(lst);
293
 
        proper_len++;
 
295
        len++;
294
296
        if (NULLP(lst)) break;
295
297
        if (!CONSP(lst))
296
 
            return SCM_LISTLEN_ENCODE_DOTTED(proper_len + TERMINATOR_LEN);
 
298
            return SCM_LISTLEN_ENCODE_DOTTED(len);
297
299
        if (lst == slow)
298
 
            return SCM_LISTLEN_ENCODE_CIRCULAR(proper_len);
 
300
            return SCM_LISTLEN_ENCODE_CIRCULAR(len);
299
301
 
300
302
        lst = CDR(lst);
301
303
        slow = CDR(slow);
302
 
        proper_len++;
 
304
        len++;
303
305
    }
304
306
 
305
 
    return proper_len;
 
307
    return len;
306
308
}
307
309
 
308
 
#undef TERMINATOR_LEN
309
 
 
310
310
SCM_EXPORT ScmObj
311
311
scm_p_length(ScmObj obj)
312
312
{
314
314
    DECLARE_FUNCTION("length", procedure_fixed_1);
315
315
 
316
316
    len = scm_length(obj);
317
 
    if (!SCM_LISTLEN_PROPERP(len))
 
317
    if (!SCM_LISTLEN_PROPERP(len)) {
 
318
        if (SCM_LISTLEN_CIRCULARP(len) && !SCM_WRITE_SS_ENABLEDP())
 
319
            ERR("proper list required but got a circular list");
318
320
        ERR_OBJ("proper list required but got", obj);
 
321
    }
319
322
 
320
323
    return MAKE_INT(len);
321
324
}
336
339
    FOR_EACH_BUTLAST (lst, args) {
337
340
        FOR_EACH (elm, lst)
338
341
            SCM_QUEUE_ADD(q, elm);
339
 
        ENSURE_PROPER_LIST_TERMINATION(lst, args);
 
342
        CHECK_PROPER_LIST_TERMINATION(lst, args);
340
343
    }
341
344
    /* append the last argument */
342
345
    SCM_QUEUE_SLOPPY_APPEND(q, lst);
347
350
SCM_EXPORT ScmObj
348
351
scm_p_reverse(ScmObj lst)
349
352
{
350
 
    ScmObj ret, elm;
 
353
    ScmObj ret, elm, rest;
351
354
    DECLARE_FUNCTION("reverse", procedure_fixed_1);
352
355
 
353
356
    ret = SCM_NULL;
354
 
    FOR_EACH (elm, lst)
 
357
    rest = lst;
 
358
    FOR_EACH (elm, rest)
355
359
        ret = CONS(elm, ret);
 
360
    CHECK_PROPER_LIST_TERMINATION(rest, lst);
356
361
 
357
362
    return ret;
358
363
}
379
384
 
380
385
    ret = scm_list_tail(lst, SCM_INT_VALUE(k));
381
386
    if (!VALIDP(ret))
382
 
        ERR_OBJ("out of range or invalid list", LIST_2(lst, k));
 
387
        ERR_OBJ("out of range", k);
383
388
 
384
389
    return ret;
385
390
}
393
398
    ENSURE_INT(k);
394
399
 
395
400
    tail = scm_list_tail(lst, SCM_INT_VALUE(k));
396
 
    if (!VALIDP(tail) || NULLP(tail))
397
 
        ERR_OBJ("out of range or invalid list", LIST_2(lst, k));
 
401
    if (!VALIDP(tail) || !CONSP(tail))
 
402
        ERR_OBJ("out of range", k);
398
403
 
399
404
    return CAR(tail);
400
405
}
401
406
 
402
407
#define MEMBER_BODY(obj, lst, cmp)                                           \
403
408
    do {                                                                     \
404
 
        for (; CONSP(lst); lst = CDR(lst))                                   \
405
 
            if (cmp(obj, CAR(lst)))                                          \
406
 
                return lst;                                                  \
407
 
        CHECK_PROPER_LIST_TERMINATION(lst, lst);                             \
 
409
        ScmObj rest;                                                         \
 
410
                                                                             \
 
411
        for (rest = lst; CONSP(rest); rest = CDR(rest))                      \
 
412
            if (cmp(obj, CAR(rest)))                                         \
 
413
                return rest;                                                 \
 
414
        CHECK_PROPER_LIST_TERMINATION(rest, lst);                            \
408
415
        return SCM_FALSE;                                                    \
409
416
    } while (/* CONSTCOND */ 0)
410
417
 
440
447
 
441
448
#define ASSOC_BODY(obj, alist, cmp)                                          \
442
449
    do {                                                                     \
443
 
        ScmObj pair, key;                                                    \
 
450
        ScmObj pair, key, rest;                                              \
444
451
                                                                             \
445
 
        FOR_EACH (pair, alist) {                                             \
 
452
        rest = alist;                                                        \
 
453
        FOR_EACH (pair, rest) {                                              \
446
454
            ENSURE_CONS(pair);                                               \
447
455
            key = CAR(pair);                                                 \
448
456
            if (cmp(key, obj))                                               \
449
457
                return pair;                                                 \
450
458
        }                                                                    \
451
 
        CHECK_PROPER_LIST_TERMINATION(alist, alist);                         \
 
459
        CHECK_PROPER_LIST_TERMINATION(rest, alist);                          \
452
460
        return SCM_FALSE;                                                    \
453
461
    } while (/* CONSTCOND */ 0)
454
462