← Back to branch summary

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

« back to all changes in this revision

Viewing changes to operations-srfi1.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:
operations-srfi1.c
1
 
/*===========================================================================
2
 
 *  FileName : operations-srfi1.c
3
 
 *  About    : srfi1 procedures
4
 
 *
5
 
 *  Copyright (C) 2005      by Kazuki Ohta (mover@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 IS''
23
 
 *  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24
 
 *  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25
 
 *  ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
26
 
 *  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27
 
 *  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
28
 
 *  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
29
 
 *  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30
 
 *  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
31
 
 *  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
32
 
 *  SUCH DAMAGE.
33
 
===========================================================================*/
34
 
 
35
 
/*=======================================
36
 
  System Include
37
 
=======================================*/
38
 
 
39
 
/*=======================================
40
 
  Local Include
41
 
=======================================*/
42
 
 
43
 
/*=======================================
44
 
  File Local Struct Declarations
45
 
=======================================*/
46
 
 
47
 
/*=======================================
48
 
  File Local Macro Declarations
49
 
=======================================*/
50
 
 
51
 
/*=======================================
52
 
  Variable Declarations
53
 
=======================================*/
54
 
 
55
 
/*=======================================
56
 
  File Local Function Declarations
57
 
=======================================*/
58
 
static ScmObj compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2);
59
 
 
60
 
/*=======================================
61
 
  Function Implementations
62
 
=======================================*/
63
 
void SigScm_Initialize_SRFI1(void)
64
 
{
65
 
    /*=======================================================================
66
 
      SRFI-1 Procedures
67
 
    =======================================================================*/
68
 
    Scm_RegisterProcedureFixed1("list-copy"            , ScmOp_SRFI1_list_copy);
69
 
    Scm_RegisterProcedureFixed2("xcons"                , ScmOp_SRFI1_xcons);
70
 
    Scm_RegisterProcedureVariadic0("circular-list"     , ScmOp_SRFI1_circular_list);
71
 
    Scm_RegisterProcedureVariadic1("iota"              , ScmOp_SRFI1_iota);
72
 
    Scm_RegisterProcedureVariadic0("cons*"             , ScmOp_SRFI1_cons_star);
73
 
    Scm_RegisterProcedureVariadic1("make-list"         , ScmOp_SRFI1_make_list);
74
 
    Scm_RegisterProcedureVariadic1("list-tabulate"     , ScmOp_SRFI1_list_tabulate);
75
 
    Scm_RegisterProcedureFixed1("proper-list?"         , ScmOp_SRFI1_proper_listp);
76
 
    Scm_RegisterProcedureFixed1("circular-list?"       , ScmOp_SRFI1_circular_listp);
77
 
    Scm_RegisterProcedureFixed1("dotted-list?"         , ScmOp_SRFI1_dotted_listp);
78
 
    Scm_RegisterProcedureFixed1("not-pair?"            , ScmOp_SRFI1_not_pairp);
79
 
    Scm_RegisterProcedureFixed1("null-list?"           , ScmOp_SRFI1_null_listp);
80
 
    Scm_RegisterProcedureVariadic1("list="             , ScmOp_SRFI1_listequal); 
81
 
    Scm_RegisterProcedureFixed1("first"                , ScmOp_SRFI1_first);
82
 
    Scm_RegisterProcedureFixed1("second"               , ScmOp_SRFI1_second);
83
 
    Scm_RegisterProcedureFixed1("third"                , ScmOp_SRFI1_third);
84
 
    Scm_RegisterProcedureFixed1("fourth"               , ScmOp_SRFI1_fourth);
85
 
    Scm_RegisterProcedureFixed1("fifth"                , ScmOp_SRFI1_fifth);
86
 
    Scm_RegisterProcedureFixed1("sixth"                , ScmOp_SRFI1_sixth);
87
 
    Scm_RegisterProcedureFixed1("seventh"              , ScmOp_SRFI1_seventh);
88
 
    Scm_RegisterProcedureFixed1("eighth"               , ScmOp_SRFI1_eighth);
89
 
    Scm_RegisterProcedureFixed1("ninth"                , ScmOp_SRFI1_ninth);
90
 
    Scm_RegisterProcedureFixed1("tenth"                , ScmOp_SRFI1_tenth);      
91
 
    Scm_RegisterProcedureFixed2("take"                 , ScmOp_SRFI1_take);
92
 
    Scm_RegisterProcedureFixed2("drop"                 , ScmOp_SRFI1_drop);
93
 
    Scm_RegisterProcedureFixed2("take-right"           , ScmOp_SRFI1_take_right);
94
 
    Scm_RegisterProcedureFixed2("drop-right"           , ScmOp_SRFI1_drop_right);
95
 
    Scm_RegisterProcedureFixed2("take!"                , ScmOp_SRFI1_take_d);
96
 
    Scm_RegisterProcedureFixed2("drop-right!"          , ScmOp_SRFI1_drop_right_d);
97
 
    Scm_RegisterProcedureFixed2("split-at"             , ScmOp_SRFI1_split_at);
98
 
    Scm_RegisterProcedureFixed2("split-at!"            , ScmOp_SRFI1_split_at_d);
99
 
    Scm_RegisterProcedureFixed1("last"                 , ScmOp_SRFI1_last);
100
 
    Scm_RegisterProcedureFixed1("last-pair"            , ScmOp_SRFI1_last_pair);
101
 
    Scm_RegisterProcedureFixed1("length+"              , ScmOp_SRFI1_lengthplus);
102
 
    Scm_RegisterProcedureVariadic0("concatenate"       , ScmOp_SRFI1_concatenate);
103
 
}
104
 
 
105
 
/*==============================================================================
106
 
  SRFI1 : The procedures : Constructors
107
 
==============================================================================*/
108
 
ScmObj ScmOp_SRFI1_xcons(ScmObj a, ScmObj b)
109
 
{
110
 
    DECLARE_FUNCTION("xcons", ProcedureFixed2);
111
 
    return CONS(b, a);
112
 
}
113
 
 
114
 
ScmObj ScmOp_SRFI1_cons_star(ScmObj args)
115
 
{
116
 
    ScmObj tail_cons = SCM_FALSE;
117
 
    ScmObj prev_last = args;
118
 
    DECLARE_FUNCTION("cons*", ProcedureVariadic0);
119
 
 
120
 
    if (NULLP(CDR(args)))
121
 
        return CAR(args);
122
 
 
123
 
    for (tail_cons = CDR(args); !NULLP(tail_cons); tail_cons = CDR(tail_cons)) {
124
 
        /* check tail cons cell */
125
 
        if (NULLP(CDR(tail_cons))) {
126
 
            SET_CDR(prev_last, CAR(tail_cons));
127
 
        }
128
 
 
129
 
        prev_last = tail_cons;
130
 
    }
131
 
 
132
 
    return args;
133
 
}
134
 
 
135
 
ScmObj ScmOp_SRFI1_make_list(ScmObj length, ScmObj args)
136
 
{
137
 
    ScmObj filler = SCM_FALSE;
138
 
    ScmObj head   = SCM_FALSE;
139
 
    int len = 0;
140
 
    int i   = 0;
141
 
    DECLARE_FUNCTION("make-list", ProcedureVariadic1);
142
 
 
143
 
    ASSERT_INTP(length);
144
 
 
145
 
    len = SCM_INT_VALUE(length);
146
 
 
147
 
    /* get filler if available */
148
 
    if (!NULLP(args))
149
 
        filler = CAR(args);
150
 
    else
151
 
        filler = SCM_FALSE;
152
 
 
153
 
    /* then create list */
154
 
    for (i = len; 0 < i; i--) {
155
 
        head = CONS(filler, head);
156
 
    }
157
 
 
158
 
    return head;
159
 
}
160
 
 
161
 
ScmObj ScmOp_SRFI1_list_tabulate(ScmObj scm_n, ScmObj args)
162
 
{
163
 
    ScmObj proc  = SCM_FALSE;
164
 
    ScmObj head  = SCM_NULL;
165
 
    ScmObj num   = SCM_FALSE;
166
 
    int n = 0;
167
 
    int i = 0;
168
 
    DECLARE_FUNCTION("list-tabulate", ProcedureVariadic1);
169
 
 
170
 
    ASSERT_INTP(scm_n);
171
 
 
172
 
    /* get n */
173
 
    n = SCM_INT_VALUE(scm_n);
174
 
 
175
 
    /* get init_proc if available */
176
 
    if (!NULLP(args))
177
 
        proc = CAR(args);
178
 
 
179
 
    /* then create list */
180
 
    for (i = n; 0 < i; i--) {
181
 
        num = Scm_NewInt(i - 1);
182
 
 
183
 
        if (!NULLP(proc))
184
 
            num = Scm_call(proc, LIST_1(num));
185
 
 
186
 
        head = CONS(num, head);
187
 
    }
188
 
 
189
 
    return head;
190
 
}
191
 
 
192
 
ScmObj ScmOp_SRFI1_list_copy(ScmObj lst)
193
 
{
194
 
    ScmObj head = SCM_FALSE;
195
 
    ScmObj tail = SCM_FALSE;
196
 
    ScmObj obj  = SCM_FALSE;
197
 
    DECLARE_FUNCTION("list-copy", ProcedureFixed1);
198
 
 
199
 
    if (FALSEP(ScmOp_listp(lst)))
200
 
        ERR_OBJ("list required but got ", lst);
201
 
 
202
 
    for (; !NULLP(lst); lst = CDR(lst)) {
203
 
        obj = CAR(lst);
204
 
 
205
 
        /* further copy */
206
 
        if (CONSP(obj))
207
 
            obj = ScmOp_SRFI1_list_copy(obj);
208
 
 
209
 
        /* then create new cons */
210
 
        obj = CONS(obj, SCM_NULL);
211
 
        if (!FALSEP(tail)) {
212
 
            SET_CDR(tail, obj);
213
 
            tail = obj;
214
 
        } else {
215
 
            head = obj;
216
 
            tail = head;
217
 
        }
218
 
    }
219
 
 
220
 
    return head;
221
 
}
222
 
 
223
 
ScmObj ScmOp_SRFI1_circular_list(ScmObj args)
224
 
{
225
 
    DECLARE_FUNCTION("circular-list", ProcedureVariadic0);
226
 
 
227
 
    if (FALSEP(ScmOp_listp(args)))
228
 
        ERR_OBJ("list required but got ", args);
229
 
 
230
 
    SET_CDR(ScmOp_SRFI1_last_pair(args), args);
231
 
    return args;
232
 
}
233
 
 
234
 
ScmObj ScmOp_SRFI1_iota(ScmObj scm_count, ScmObj args)
235
 
{
236
 
    ScmObj scm_start = SCM_FALSE;
237
 
    ScmObj scm_step  = SCM_FALSE;
238
 
    ScmObj head      = SCM_NULL;
239
 
    int count = 0;
240
 
    int start = 0;
241
 
    int step  = 0;
242
 
    int i = 0;
243
 
    DECLARE_FUNCTION("iota", ProcedureVariadic1);
244
 
 
245
 
    /* get params */
246
 
    if (!NULLP(args))
247
 
        scm_start = CAR(args);
248
 
 
249
 
    if (!NULLP(scm_start) && !NULLP(CDR(args)))
250
 
        scm_step = CAR(CDR(args));
251
 
 
252
 
    /* param type check */
253
 
    ASSERT_INTP(scm_count);
254
 
    if (!NULLP(scm_start))
255
 
        ASSERT_INTP(scm_start);
256
 
    if (!NULLP(scm_step))
257
 
        ASSERT_INTP(scm_step);
258
 
 
259
 
    /* now create list */
260
 
    count = SCM_INT_VALUE(scm_count);
261
 
    start = NULLP(scm_start) ? 0 : SCM_INT_VALUE(scm_start);
262
 
    step  = NULLP(scm_step)  ? 1 : SCM_INT_VALUE(scm_step);
263
 
    for (i = count - 1; 0 <= i; i--) {
264
 
        head = CONS(Scm_NewInt(start + i*step), head);
265
 
    }
266
 
 
267
 
    return head;
268
 
}
269
 
 
270
 
/*==============================================================================
271
 
  SRFI1 : The procedures : Predicates
272
 
==============================================================================*/
273
 
ScmObj ScmOp_SRFI1_proper_listp(ScmObj lst)
274
 
{
275
 
    DECLARE_FUNCTION("proper-list?", ProcedureFixed1);
276
 
    return ScmOp_listp(lst);
277
 
}
278
 
 
279
 
ScmObj ScmOp_SRFI1_circular_listp(ScmObj obj)
280
 
{
281
 
    ScmObj slow = obj;
282
 
    int len = 0;
283
 
    DECLARE_FUNCTION("circular-list?", ProcedureFixed1);
284
 
 
285
 
    for (;;) {
286
 
        if (NULLP(obj)) break;
287
 
        if (!CONSP(obj)) return SCM_FALSE;
288
 
        if (len != 0 && obj == slow) return SCM_TRUE; /* circular */
289
 
 
290
 
        obj = CDR(obj);
291
 
        len++;
292
 
        if (NULLP(obj)) break;
293
 
        if (!CONSP(obj)) return SCM_FALSE;
294
 
        if (obj == slow) return SCM_TRUE; /* circular */
295
 
 
296
 
        obj = CDR(obj);
297
 
        slow = CDR(slow);
298
 
        len++;
299
 
    }
300
 
 
301
 
    return SCM_FALSE;
302
 
}
303
 
 
304
 
ScmObj ScmOp_SRFI1_dotted_listp(ScmObj obj)
305
 
{
306
 
    ScmObj slow = obj;
307
 
    int len = 0;
308
 
    DECLARE_FUNCTION("dotted-list?", ProcedureFixed1);
309
 
 
310
 
    for (;;) {
311
 
        if (NULLP(obj)) break;
312
 
        if (!CONSP(obj)) return SCM_TRUE;
313
 
        if (len != 0 && obj == slow) return SCM_FALSE; /* circular */
314
 
 
315
 
        obj = CDR(obj);
316
 
        len++;
317
 
        if (NULLP(obj)) break;
318
 
        if (!CONSP(obj)) return SCM_TRUE;
319
 
        if (obj == slow) return SCM_FALSE; /* circular */
320
 
 
321
 
        obj = CDR(obj);
322
 
        slow = CDR(slow);
323
 
        len++;
324
 
    }
325
 
 
326
 
    return SCM_FALSE;
327
 
}
328
 
 
329
 
ScmObj ScmOp_SRFI1_not_pairp(ScmObj pair)
330
 
{
331
 
    DECLARE_FUNCTION("not-pari?", ProcedureFixed1);
332
 
    return CONSP(pair) ? SCM_FALSE : SCM_TRUE;
333
 
}
334
 
 
335
 
ScmObj ScmOp_SRFI1_null_listp(ScmObj lst)
336
 
{
337
 
    DECLARE_FUNCTION("null-list?", ProcedureFixed1);
338
 
    /* TODO : check circular list */
339
 
    return NULLP(lst) ? SCM_TRUE : SCM_FALSE;
340
 
}
341
 
 
342
 
ScmObj ScmOp_SRFI1_listequal(ScmObj eqproc, ScmObj args)
343
 
{
344
 
    ScmObj first_lst = SCM_FALSE;
345
 
    DECLARE_FUNCTION("list=", ProcedureVariadic1);
346
 
 
347
 
    if (NULLP(args))
348
 
        return SCM_TRUE;
349
 
 
350
 
    first_lst = CAR(args);
351
 
    args = CDR(args);
352
 
 
353
 
    if (NULLP(args))
354
 
        return SCM_TRUE;
355
 
 
356
 
    for (; !NULLP(args); args = CDR(args)) {
357
 
        if (FALSEP(compare_list(eqproc, first_lst, CAR(args))))
358
 
            return SCM_FALSE;
359
 
    }
360
 
 
361
 
    return SCM_TRUE;
362
 
}
363
 
 
364
 
static ScmObj compare_list(ScmObj eqproc, ScmObj lst1, ScmObj lst2)
365
 
{
366
 
#define CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, obj1, obj2)             \
367
 
    (Scm_call(eqproc,                                                   \
368
 
              LIST_2(obj1, obj2)))
369
 
 
370
 
    ScmObj ret_cmp = SCM_FALSE;
371
 
 
372
 
    for (; !NULLP(lst1); lst1 = CDR(lst1), lst2 = CDR(lst2)) {
373
 
        /* check contents */
374
 
        ret_cmp = CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, CAR(lst1), CAR(lst2));
375
 
        if (FALSEP(ret_cmp))
376
 
            return SCM_FALSE;
377
 
 
378
 
        /* check next cdr's type */
379
 
        if (SCM_TYPE(CDR(lst1)) != SCM_TYPE(CDR(lst2)))
380
 
            return SCM_FALSE;
381
 
 
382
 
        /* check dot pair */
383
 
        if (!CONSP(CDR(lst1))) {
384
 
            return CHECK_LIST_EQUALITY_WITH_EQPROC(eqproc, CDR(lst1), CDR(lst2));
385
 
        }
386
 
    }
387
 
    return SCM_TRUE;
388
 
}
389
 
 
390
 
ScmObj ScmOp_SRFI1_first(ScmObj lst)
391
 
{
392
 
    DECLARE_FUNCTION("first", ProcedureFixed1);
393
 
    return ScmOp_car(lst);
394
 
}
395
 
 
396
 
ScmObj ScmOp_SRFI1_second(ScmObj lst)
397
 
{
398
 
    DECLARE_FUNCTION("second", ProcedureFixed1);
399
 
    return ScmOp_cadr(lst);
400
 
}
401
 
 
402
 
ScmObj ScmOp_SRFI1_third(ScmObj lst)
403
 
{
404
 
    DECLARE_FUNCTION("third", ProcedureFixed1);
405
 
    return ScmOp_caddr(lst);
406
 
}
407
 
 
408
 
ScmObj ScmOp_SRFI1_fourth(ScmObj lst)
409
 
{
410
 
    DECLARE_FUNCTION("fourth", ProcedureFixed1);
411
 
    return ScmOp_cadddr(lst);
412
 
}
413
 
 
414
 
ScmObj ScmOp_SRFI1_fifth(ScmObj lst)
415
 
{
416
 
    DECLARE_FUNCTION("fifth", ProcedureFixed1);
417
 
    return ScmOp_car(ScmOp_cddddr(lst));
418
 
}
419
 
 
420
 
ScmObj ScmOp_SRFI1_sixth(ScmObj lst)
421
 
{
422
 
    DECLARE_FUNCTION("sixth", ProcedureFixed1);
423
 
    return ScmOp_cadr(ScmOp_cddddr(lst));
424
 
}
425
 
 
426
 
ScmObj ScmOp_SRFI1_seventh(ScmObj lst)
427
 
{
428
 
    DECLARE_FUNCTION("seventh", ProcedureFixed1);
429
 
    return ScmOp_caddr(ScmOp_cddddr(lst));
430
 
}
431
 
 
432
 
ScmObj ScmOp_SRFI1_eighth(ScmObj lst)
433
 
{
434
 
    DECLARE_FUNCTION("eighth", ProcedureFixed1);
435
 
    return ScmOp_cadddr(ScmOp_cddddr(lst));
436
 
}
437
 
 
438
 
ScmObj ScmOp_SRFI1_ninth(ScmObj lst)
439
 
{
440
 
    DECLARE_FUNCTION("ninth", ProcedureFixed1);
441
 
    return ScmOp_car(ScmOp_cddddr(ScmOp_cddddr(lst)));
442
 
}
443
 
 
444
 
ScmObj ScmOp_SRFI1_tenth(ScmObj lst)
445
 
{
446
 
    DECLARE_FUNCTION("tenth", ProcedureFixed1);
447
 
    return ScmOp_cadr(ScmOp_cddddr(ScmOp_cddddr(lst)));
448
 
}
449
 
 
450
 
ScmObj ScmOp_SRFI1_carpluscdr(ScmObj lst)
451
 
{
452
 
    DECLARE_FUNCTION("car+cdr", ProcedureFixed1);
453
 
    return ScmOp_values(LIST_2(CAR(lst), CDR(lst)));
454
 
}
455
 
 
456
 
ScmObj ScmOp_SRFI1_take(ScmObj lst, ScmObj scm_idx)
457
 
{
458
 
    ScmObj tmp      = lst;
459
 
    ScmObj ret      = SCM_FALSE;
460
 
    ScmObj ret_tail = SCM_FALSE;
461
 
    int idx = 0;
462
 
    int i;
463
 
    DECLARE_FUNCTION("take", ProcedureFixed2);
464
 
 
465
 
    ASSERT_INTP(scm_idx);
466
 
 
467
 
    idx = SCM_INT_VALUE(scm_idx);
468
 
    for (i = 0; i < idx; i++) {
469
 
        if (SCM_NULLP(tmp))
470
 
            ERR_OBJ("illegal index is specified for ", lst);
471
 
 
472
 
        if (i != 0) {
473
 
            SET_CDR(ret_tail,  CONS(CAR(tmp), SCM_NULL));
474
 
            ret_tail = CDR(ret_tail);
475
 
        } else {
476
 
            ret = CONS(CAR(tmp), SCM_NULL);
477
 
            ret_tail = ret;
478
 
        }
479
 
 
480
 
        tmp = CDR(tmp);
481
 
    }
482
 
 
483
 
    return ret;
484
 
}
485
 
 
486
 
ScmObj ScmOp_SRFI1_drop(ScmObj lst, ScmObj scm_idx)
487
 
{
488
 
    ScmObj ret = lst;
489
 
    int idx = 0;
490
 
    int i;
491
 
    DECLARE_FUNCTION("drop", ProcedureFixed2);
492
 
 
493
 
    ASSERT_INTP(scm_idx);
494
 
 
495
 
    idx = SCM_INT_VALUE(scm_idx);
496
 
    for (i = 0; i < idx; i++) {
497
 
        if (!CONSP(ret))
498
 
            ERR_OBJ("illegal index is specified for ", lst);
499
 
 
500
 
        ret = CDR(ret);
501
 
    }
502
 
 
503
 
    return ret;
504
 
}
505
 
 
506
 
ScmObj ScmOp_SRFI1_take_right(ScmObj lst, ScmObj scm_elem)
507
 
{
508
 
    ScmObj tmp = lst;
509
 
    int len = 0;
510
 
    DECLARE_FUNCTION("take-right", ProcedureFixed2);
511
 
 
512
 
    ASSERT_INTP(scm_elem);
513
 
 
514
 
    for (; CONSP(tmp); tmp = CDR(tmp))
515
 
        len++;
516
 
 
517
 
    len -= SCM_INT_VALUE(scm_elem);
518
 
 
519
 
    return ScmOp_SRFI1_drop(lst, Scm_NewInt(len));
520
 
}
521
 
 
522
 
ScmObj ScmOp_SRFI1_drop_right(ScmObj lst, ScmObj scm_elem)
523
 
{
524
 
    ScmObj tmp = lst;
525
 
    int len = 0;
526
 
    DECLARE_FUNCTION("drop-right", ProcedureFixed2);
527
 
 
528
 
    ASSERT_INTP(scm_elem);
529
 
 
530
 
    for (; CONSP(tmp); tmp = CDR(tmp))
531
 
        len++;
532
 
 
533
 
    len -= SCM_INT_VALUE(scm_elem);
534
 
 
535
 
    return ScmOp_SRFI1_take(lst, Scm_NewInt(len));
536
 
}
537
 
 
538
 
ScmObj ScmOp_SRFI1_take_d(ScmObj lst, ScmObj scm_idx)
539
 
{
540
 
    ScmObj tmp = lst;
541
 
    int idx = 0;
542
 
    int i;
543
 
    DECLARE_FUNCTION("take!", ProcedureFixed2);
544
 
 
545
 
    ASSERT_INTP(scm_idx);
546
 
 
547
 
    idx = SCM_INT_VALUE(scm_idx);
548
 
 
549
 
    for (i = 0; i < idx - 1; i++) {
550
 
        tmp = CDR(tmp);
551
 
    }
552
 
 
553
 
    SET_CDR(tmp, SCM_NULL);
554
 
 
555
 
    return lst;
556
 
}
557
 
 
558
 
ScmObj ScmOp_SRFI1_drop_right_d(ScmObj lst, ScmObj scm_idx)
559
 
{
560
 
    ScmObj tmp = lst;
561
 
    int len = 0;
562
 
    int i;
563
 
    DECLARE_FUNCTION("drop-right!", ProcedureFixed2);
564
 
 
565
 
    ASSERT_INTP(scm_idx);
566
 
 
567
 
    for (; CONSP(tmp); tmp = CDR(tmp))
568
 
        len++;
569
 
 
570
 
    len -= SCM_INT_VALUE(scm_idx);
571
 
 
572
 
    tmp = lst;
573
 
    for (i = 0; i < len - 1; i++) {
574
 
        tmp = CDR(tmp);
575
 
    }
576
 
 
577
 
    SET_CDR(tmp, SCM_NULL);
578
 
 
579
 
    return lst;
580
 
}
581
 
 
582
 
ScmObj ScmOp_SRFI1_split_at(ScmObj lst, ScmObj idx)
583
 
{
584
 
    DECLARE_FUNCTION("split-at", ProcedureFixed2);
585
 
 
586
 
    return ScmOp_values(LIST_2(ScmOp_SRFI1_take(lst, idx),
587
 
                               ScmOp_SRFI1_drop(lst, idx)));
588
 
}
589
 
 
590
 
ScmObj ScmOp_SRFI1_split_at_d(ScmObj lst, ScmObj idx)
591
 
{
592
 
    ScmObj drop = ScmOp_SRFI1_drop(lst, idx);
593
 
    DECLARE_FUNCTION("split-at!", ProcedureFixed2);
594
 
 
595
 
    return ScmOp_values(LIST_2(ScmOp_SRFI1_take_d(lst, idx),
596
 
                               drop));
597
 
}
598
 
 
599
 
ScmObj ScmOp_SRFI1_last(ScmObj lst)
600
 
{
601
 
    DECLARE_FUNCTION("last", ProcedureFixed1);
602
 
 
603
 
    /* sanity check */
604
 
    if (NULLP(lst))
605
 
        ERR_OBJ("non-empty, proper list is required but got ", lst);
606
 
 
607
 
    return CAR(ScmOp_SRFI1_last_pair(lst));
608
 
}
609
 
 
610
 
ScmObj ScmOp_SRFI1_last_pair(ScmObj lst)
611
 
{
612
 
    DECLARE_FUNCTION("last-pair", ProcedureFixed1);
613
 
 
614
 
    /* sanity check */
615
 
    if (NULLP(lst))
616
 
        ERR_OBJ("non-empty, proper list is required but got ", lst);
617
 
 
618
 
    for (; CONSP(CDR(lst)); lst = CDR(lst))
619
 
        ;
620
 
 
621
 
    return lst;
622
 
}
623
 
 
624
 
/*==============================================================================
625
 
  SRFI1 : The procedures : Miscellaneous
626
 
==============================================================================*/
627
 
ScmObj ScmOp_SRFI1_lengthplus(ScmObj lst)
628
 
{
629
 
    DECLARE_FUNCTION("length+", ProcedureFixed0);
630
 
 
631
 
    /* FIXME!: remove expensive circular_listp */
632
 
    if (NFALSEP(ScmOp_SRFI1_circular_listp(lst)))
633
 
        return SCM_FALSE;
634
 
 
635
 
    return ScmOp_length(lst);
636
 
}
637
 
 
638
 
ScmObj ScmOp_SRFI1_concatenate(ScmObj args)
639
 
{
640
 
    ScmObj lsts_of_lst = CAR(args);
641
 
    DECLARE_FUNCTION("concatenate", ProcedureFixed0);
642
 
 
643
 
#if SCM_STRICT_ARGCHECK
644
 
    if (!NULLP(CDR(args)))
645
 
        ERR_OBJ("superfluous arguments: ", args);
646
 
#endif
647
 
 
648
 
    return ScmOp_append(lsts_of_lst);
649
 
}