1 /*===========================================================================
2 * Filename : list.c
3 * About : R5SR pairs and lists
4 *
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-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
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.
24 *
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 ===========================================================================*/
37
38 /* scm_length() is covered by following license */
39 /*
40 * list.c - List related functions
41 *
42 * Copyright (c) 2000-2004 Shiro Kawai, All rights reserved.
43 *
44 * Redistribution and use in source and binary forms, with or without
45 * modification, are permitted provided that the following conditions
46 * are met:
47 *
48 * 1. Redistributions of source code must retain the above copyright
49 * notice, this list of conditions and the following disclaimer.
50 *
51 * 2. Redistributions in binary form must reproduce the above copyright
52 * notice, this list of conditions and the following disclaimer in the
53 * documentation and/or other materials provided with the distribution.
54 *
55 * 3. Neither the name of the authors nor the names of its contributors
56 * may be used to endorse or promote products derived from this
57 * software without specific prior written permission.
58 *
59 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
60 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
61 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
62 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
63 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
64 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
65 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
66 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
67 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
68 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
69 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
70 *
71 * $Id: list.c,v 1.45 2005/04/12 01:42:27 shirok Exp $
72 */
73
74 #include <config.h>
75
76 #include "sigscheme.h"
77 #include "sigschemeinternal.h"
78
79 /*=======================================
80 File Local Macro Definitions
81 =======================================*/
82
83 /*=======================================
84 File Local Type Definitions
85 =======================================*/
86
87 /*=======================================
88 Variable Definitions
89 =======================================*/
90
91 /*=======================================
92 File Local Function Declarations
93 =======================================*/
94
95 /*=======================================
96 Function Definitions
97 =======================================*/
98 /*===========================================================================
99 R5RS : 6.3 Other data types : 6.3.2 Pairs and lists
100 ===========================================================================*/
101 SCM_EXPORT ScmObj
scm_p_pairp(ScmObj obj)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
scm_p_cons(ScmObj car,ScmObj cdr)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
scm_p_car(ScmObj obj)118 scm_p_car(ScmObj obj)
119 {
120 DECLARE_FUNCTION("car", procedure_fixed_1);
121 #if SCM_COMPAT_SIOD_BUGS
122 if (NULLP(obj))
123 return SCM_NULL;
124 #endif
125
126 ENSURE_CONS(obj);
127
128 return CAR(obj);
129 }
130
131 SCM_EXPORT ScmObj
scm_p_cdr(ScmObj obj)132 scm_p_cdr(ScmObj obj)
133 {
134 DECLARE_FUNCTION("cdr", procedure_fixed_1);
135 #if SCM_COMPAT_SIOD_BUGS
136 if (NULLP(obj))
137 return SCM_NULL;
138 #endif
139
140 ENSURE_CONS(obj);
141
142 return CDR(obj);
143 }
144
145 SCM_EXPORT ScmObj
scm_p_set_carx(ScmObj pair,ScmObj car)146 scm_p_set_carx(ScmObj pair, ScmObj car)
147 {
148 DECLARE_FUNCTION("set-car!", procedure_fixed_2);
149
150 ENSURE_CONS(pair);
151 ENSURE_MUTABLE_CONS(pair);
152
153 SET_CAR(pair, car);
154
155 #if SCM_COMPAT_SIOD
156 return car;
157 #else
158 return SCM_UNDEF;
159 #endif
160 }
161
162 SCM_EXPORT ScmObj
scm_p_set_cdrx(ScmObj pair,ScmObj cdr)163 scm_p_set_cdrx(ScmObj pair, ScmObj cdr)
164 {
165 DECLARE_FUNCTION("set-cdr!", procedure_fixed_2);
166
167 ENSURE_CONS(pair);
168 ENSURE_MUTABLE_CONS(pair);
169
170 SET_CDR(pair, cdr);
171
172 #if SCM_COMPAT_SIOD
173 return cdr;
174 #else
175 return SCM_UNDEF;
176 #endif
177 }
178
179 SCM_EXPORT ScmObj
scm_p_caar(ScmObj lst)180 scm_p_caar(ScmObj lst)
181 {
182 DECLARE_FUNCTION("caar", procedure_fixed_1);
183
184 return scm_p_car(scm_p_car(lst));
185 }
186
187 SCM_EXPORT ScmObj
scm_p_cadr(ScmObj lst)188 scm_p_cadr(ScmObj lst)
189 {
190 DECLARE_FUNCTION("cadr", procedure_fixed_1);
191
192 return scm_p_car(scm_p_cdr(lst));
193 }
194
195 SCM_EXPORT ScmObj
scm_p_cdar(ScmObj lst)196 scm_p_cdar(ScmObj lst)
197 {
198 DECLARE_FUNCTION("cdar", procedure_fixed_1);
199
200 return scm_p_cdr(scm_p_car(lst));
201 }
202
203 SCM_EXPORT ScmObj
scm_p_cddr(ScmObj lst)204 scm_p_cddr(ScmObj lst)
205 {
206 DECLARE_FUNCTION("cddr", procedure_fixed_1);
207
208 return scm_p_cdr(scm_p_cdr(lst));
209 }
210
211 SCM_EXPORT ScmObj
scm_p_caddr(ScmObj lst)212 scm_p_caddr(ScmObj lst)
213 {
214 DECLARE_FUNCTION("caddr", procedure_fixed_1);
215
216 return scm_p_car(scm_p_cdr(scm_p_cdr(lst)));
217 }
218
219 SCM_EXPORT ScmObj
scm_p_cdddr(ScmObj lst)220 scm_p_cdddr(ScmObj lst)
221 {
222 DECLARE_FUNCTION("cdddr", procedure_fixed_1);
223
224 return scm_p_cdr(scm_p_cdr(scm_p_cdr(lst)));
225 }
226
227 SCM_EXPORT ScmObj
scm_p_nullp(ScmObj obj)228 scm_p_nullp(ScmObj obj)
229 {
230 DECLARE_FUNCTION("null?", procedure_fixed_1);
231
232 return MAKE_BOOL(NULLP(obj));
233 }
234
235 SCM_EXPORT ScmObj
scm_p_listp(ScmObj obj)236 scm_p_listp(ScmObj obj)
237 {
238 DECLARE_FUNCTION("list?", procedure_fixed_1);
239
240 /* fast path */
241 if (NULLP(obj))
242 return SCM_TRUE;
243 if (!CONSP(obj))
244 return SCM_FALSE;
245
246 return MAKE_BOOL(PROPER_LISTP(obj));
247 }
248
249 SCM_EXPORT ScmObj
scm_p_list(ScmObj args)250 scm_p_list(ScmObj args)
251 {
252 DECLARE_FUNCTION("list", procedure_variadic_0);
253
254 return args;
255 }
256
257 /* scm_length() for non-circular list */
258 SCM_EXPORT scm_int_t
scm_finite_length(ScmObj lst)259 scm_finite_length(ScmObj lst)
260 {
261 scm_int_t len;
262
263 for (len = 0; CONSP(lst); lst = CDR(lst))
264 len++;
265
266 if (NULLP(lst))
267 return len;
268 else
269 return SCM_LISTLEN_ENCODE_DOTTED(len);
270 }
271
272 /*
273 * ChangeLog for scm_length()
274 *
275 * 2005-08-12 kzk Copied from Scm_Length() of Gauche 0.8.5.
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.
278 *
279 */
280 /* Returns -1 as one length improper list for non-list obj. */
281 SCM_EXPORT scm_int_t
scm_length(ScmObj lst)282 scm_length(ScmObj lst)
283 {
284 ScmObj slow;
285 scm_int_t len;
286
287 for (len = 0, slow = lst;;) {
288 if (NULLP(lst)) break;
289 if (!CONSP(lst))
290 return SCM_LISTLEN_ENCODE_DOTTED(len);
291 if (len != 0 && lst == slow)
292 return SCM_LISTLEN_ENCODE_CIRCULAR(len);
293
294 lst = CDR(lst);
295 len++;
296 if (NULLP(lst)) break;
297 if (!CONSP(lst))
298 return SCM_LISTLEN_ENCODE_DOTTED(len);
299 if (lst == slow)
300 return SCM_LISTLEN_ENCODE_CIRCULAR(len);
301
302 lst = CDR(lst);
303 slow = CDR(slow);
304 len++;
305 }
306
307 return len;
308 }
309
310 SCM_EXPORT ScmObj
scm_p_length(ScmObj obj)311 scm_p_length(ScmObj obj)
312 {
313 scm_int_t len;
314 DECLARE_FUNCTION("length", procedure_fixed_1);
315
316 len = scm_length(obj);
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");
320 ERR_OBJ("proper list required but got", obj);
321 }
322
323 return MAKE_INT(len);
324 }
325
326 SCM_EXPORT ScmObj
scm_p_append(ScmObj args)327 scm_p_append(ScmObj args)
328 {
329 ScmQueue q;
330 ScmObj lst, elm, ret;
331 DECLARE_FUNCTION("append", procedure_variadic_0);
332
333 if (NULLP(args))
334 return SCM_NULL;
335
336 ret = SCM_NULL;
337 SCM_QUEUE_POINT_TO(q, ret);
338 /* duplicate and merge all but the last argument */
339 FOR_EACH_BUTLAST (lst, args) {
340 FOR_EACH (elm, lst)
341 SCM_QUEUE_ADD(q, elm);
342 CHECK_PROPER_LIST_TERMINATION(lst, args);
343 }
344 /* append the last argument */
345 SCM_QUEUE_SLOPPY_APPEND(q, lst);
346
347 return ret;
348 }
349
350 SCM_EXPORT ScmObj
scm_p_reverse(ScmObj lst)351 scm_p_reverse(ScmObj lst)
352 {
353 ScmObj ret, elm, rest;
354 DECLARE_FUNCTION("reverse", procedure_fixed_1);
355
356 ret = SCM_NULL;
357 rest = lst;
358 FOR_EACH (elm, rest)
359 ret = CONS(elm, ret);
360 CHECK_PROPER_LIST_TERMINATION(rest, lst);
361
362 return ret;
363 }
364
365 SCM_EXPORT ScmObj
scm_list_tail(ScmObj lst,scm_int_t k)366 scm_list_tail(ScmObj lst, scm_int_t k)
367 {
368 while (k--) {
369 if (!CONSP(lst))
370 return SCM_INVALID;
371 lst = CDR(lst);
372 }
373
374 return lst;
375 }
376
377 /* Since this procedure is also used as SRFI-1 'drop', following specification
378 * must also be satisfied.
379 *
380 * SRFI-1: drop returns all but the first i elements of list x.
381 * x may be any value -- a proper, circular, or dotted list. */
382 SCM_EXPORT ScmObj
scm_p_list_tail(ScmObj lst,ScmObj k)383 scm_p_list_tail(ScmObj lst, ScmObj k)
384 {
385 ScmObj ret;
386 DECLARE_FUNCTION("list-tail", procedure_fixed_2);
387
388 ENSURE_INT(k);
389
390 ret = scm_list_tail(lst, SCM_INT_VALUE(k));
391 if (!VALIDP(ret))
392 ERR_OBJ("out of range", k);
393
394 return ret;
395 }
396
397 SCM_EXPORT ScmObj
scm_p_list_ref(ScmObj lst,ScmObj k)398 scm_p_list_ref(ScmObj lst, ScmObj k)
399 {
400 ScmObj tail;
401 DECLARE_FUNCTION("list-ref", procedure_fixed_2);
402
403 ENSURE_INT(k);
404
405 tail = scm_list_tail(lst, SCM_INT_VALUE(k));
406 if (!VALIDP(tail) || !CONSP(tail))
407 ERR_OBJ("out of range", k);
408
409 return CAR(tail);
410 }
411
412 #define MEMBER_BODY(obj, lst, cmp) \
413 do { \
414 ScmObj rest; \
415 \
416 for (rest = lst; CONSP(rest); rest = CDR(rest)) \
417 if (cmp(obj, CAR(rest))) \
418 return rest; \
419 CHECK_PROPER_LIST_TERMINATION(rest, lst); \
420 return SCM_FALSE; \
421 } while (/* CONSTCOND */ 0)
422
423 SCM_EXPORT ScmObj
scm_p_memq(ScmObj obj,ScmObj lst)424 scm_p_memq(ScmObj obj, ScmObj lst)
425 {
426 DECLARE_FUNCTION("memq", procedure_fixed_2);
427
428 MEMBER_BODY(obj, lst, EQ);
429 }
430
431 SCM_EXPORT ScmObj
scm_p_memv(ScmObj obj,ScmObj lst)432 scm_p_memv(ScmObj obj, ScmObj lst)
433 {
434 DECLARE_FUNCTION("memv", procedure_fixed_2);
435
436 #if (SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)
437 MEMBER_BODY(obj, lst, EQ);
438 #else
439 MEMBER_BODY(obj, lst, EQVP);
440 #endif
441 }
442
443 SCM_EXPORT ScmObj
scm_p_member(ScmObj obj,ScmObj lst)444 scm_p_member(ScmObj obj, ScmObj lst)
445 {
446 DECLARE_FUNCTION("member", procedure_fixed_2);
447
448 MEMBER_BODY(obj, lst, EQUALP);
449 }
450
451 #undef MEMBER_BODY
452
453 #define ASSOC_BODY(obj, alist, cmp) \
454 do { \
455 ScmObj pair, key, rest; \
456 \
457 rest = alist; \
458 FOR_EACH (pair, rest) { \
459 ENSURE_CONS(pair); \
460 key = CAR(pair); \
461 if (cmp(key, obj)) \
462 return pair; \
463 } \
464 CHECK_PROPER_LIST_TERMINATION(rest, alist); \
465 return SCM_FALSE; \
466 } while (/* CONSTCOND */ 0)
467
468 SCM_EXPORT ScmObj
scm_p_assq(ScmObj obj,ScmObj alist)469 scm_p_assq(ScmObj obj, ScmObj alist)
470 {
471 DECLARE_FUNCTION("assq", procedure_fixed_2);
472
473 ASSOC_BODY(obj, alist, EQ);
474 }
475
476 SCM_EXPORT ScmObj
scm_p_assv(ScmObj obj,ScmObj alist)477 scm_p_assv(ScmObj obj, ScmObj alist)
478 {
479 DECLARE_FUNCTION("assv", procedure_fixed_2);
480
481 #if (SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)
482 ASSOC_BODY(obj, alist, EQ);
483 #else
484 ASSOC_BODY(obj, alist, EQVP);
485 #endif
486 }
487
488 SCM_EXPORT ScmObj
scm_p_assoc(ScmObj obj,ScmObj alist)489 scm_p_assoc(ScmObj obj, ScmObj alist)
490 {
491 DECLARE_FUNCTION("assoc", procedure_fixed_2);
492
493 ASSOC_BODY(obj, alist, EQUALP);
494 }
495
496 #undef ASSOC_BODY
497