2197a61f5395e3a80d95f9470ee9b0b42d9d28bb
1 /* Copyright (C) 1995,1996,1997,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
44 #include "libguile/_scm.h"
45 #include "libguile/eq.h"
46 #include "libguile/lang.h"
48 #include "libguile/validate.h"
49 #include "libguile/list.h"
53 #define var_start(x, y) va_start(x, y)
56 #define var_start(x, y) va_start(x)
62 #define SCM_I_CONS(cell,x,y) \
64 cell = scm_alloc_cell ((scm_t_bits)x, (scm_t_bits)y); \
71 SCM_I_CONS (c1
, e1
, SCM_EOL
);
76 scm_list_2 (SCM e1
, SCM e2
)
79 SCM_I_CONS (c2
, e2
, SCM_EOL
);
80 SCM_I_CONS (c1
, e1
, c2
);
85 scm_list_3 (SCM e1
, SCM e2
, SCM e3
)
88 SCM_I_CONS (c3
, e3
, SCM_EOL
);
89 SCM_I_CONS (c2
, e2
, c3
);
90 SCM_I_CONS (c1
, e1
, c2
);
95 scm_list_4 (SCM e1
, SCM e2
, SCM e3
, SCM e4
)
97 return scm_cons2 (e1
, e2
, scm_list_2 (e3
, e4
));
101 scm_list_5 (SCM e1
, SCM e2
, SCM e3
, SCM e4
, SCM e5
)
103 return scm_cons2 (e1
, e2
, scm_list_3 (e3
, e4
, e5
));
107 scm_list_n (SCM elt
, ...)
110 SCM answer
= SCM_EOL
;
113 var_start (foo
, elt
);
114 while (! SCM_UNBNDP (elt
))
116 *pos
= scm_cons (elt
, SCM_EOL
);
117 pos
= SCM_CDRLOC (*pos
);
118 elt
= va_arg (foo
, SCM
);
124 SCM_DEFINE (scm_list
, "list", 0, 0, 1,
126 "Return a list containing @var{objs}, the arguments to\n"
128 #define FUNC_NAME s_scm_list
135 SCM_DEFINE (scm_cons_star
, "cons*", 1, 0, 1,
137 "Like @code{list}, but the last arg provides the tail of the\n"
138 "constructed list, returning @code{(cons @var{arg1} (cons\n"
139 "@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one\n"
140 "argument. If given one argument, that argument is returned as\n"
141 "result. This function is called @code{list*} in some other\n"
142 "Schemes and in Common LISP.")
143 #define FUNC_NAME s_scm_cons_star
145 SCM_VALIDATE_REST_ARGUMENT (rest
);
146 if (!SCM_NULLP (rest
))
148 SCM prev
= arg
= scm_cons (arg
, rest
);
149 while (SCM_NNULLP (SCM_CDR (rest
)))
152 rest
= SCM_CDR (rest
);
154 SCM_SETCDR (prev
, SCM_CAR (rest
));
162 /* general questions about lists --- null?, list?, length, etc. */
164 SCM_DEFINE (scm_null_p
, "null?", 1, 0, 0,
166 "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
167 #define FUNC_NAME s_scm_null_p
169 return SCM_BOOL (SCM_NULL_OR_NIL_P (x
));
174 SCM_DEFINE (scm_list_p
, "list?", 1, 0, 0,
176 "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
177 #define FUNC_NAME s_scm_list_p
179 return SCM_BOOL (scm_ilength (x
) >= 0);
184 /* Return the length of SX, or -1 if it's not a proper list.
185 This uses the "tortoise and hare" algorithm to detect "infinitely
186 long" lists (i.e. lists with cycles in their cdrs), and returns -1
187 if it does find one. */
196 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
197 if (SCM_NCONSP(hare
)) return -1;
198 hare
= SCM_CDR(hare
);
200 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
201 if (SCM_NCONSP(hare
)) return -1;
202 hare
= SCM_CDR(hare
);
204 /* For every two steps the hare takes, the tortoise takes one. */
205 tortoise
= SCM_CDR(tortoise
);
207 while (! SCM_EQ_P (hare
, tortoise
));
209 /* If the tortoise ever catches the hare, then the list must contain
215 SCM_DEFINE (scm_length
, "length", 1, 0, 0,
217 "Return the number of elements in list @var{lst}.")
218 #define FUNC_NAME s_scm_length
221 SCM_VALIDATE_LIST_COPYLEN (1,lst
,i
);
222 return SCM_MAKINUM (i
);
228 /* appending lists */
230 SCM_DEFINE (scm_append
, "append", 0, 0, 1,
232 "Return a list consisting of the elements the lists passed as\n"
235 "(append '(x) '(y)) @result{} (x y)\n"
236 "(append '(a) '(b c d)) @result{} (a b c d)\n"
237 "(append '(a (b)) '((c))) @result{} (a (b) (c))\n"
239 "The resulting list is always newly allocated, except that it\n"
240 "shares structure with the last list argument. The last\n"
241 "argument may actually be any object; an improper list results\n"
242 "if the last argument is not a proper list.\n"
244 "(append '(a b) '(c . d)) @result{} (a b c . d)\n"
245 "(append '() 'a) @result{} a\n"
247 #define FUNC_NAME s_scm_append
249 SCM_VALIDATE_REST_ARGUMENT (args
);
250 if (SCM_NULLP (args
)) {
255 SCM arg
= SCM_CAR (args
);
256 args
= SCM_CDR (args
);
257 while (!SCM_NULLP (args
)) {
258 while (SCM_CONSP (arg
)) {
259 *lloc
= scm_cons (SCM_CAR (arg
), SCM_EOL
);
260 lloc
= SCM_CDRLOC (*lloc
);
263 SCM_VALIDATE_NULL_OR_NIL (SCM_ARGn
, arg
);
264 arg
= SCM_CAR (args
);
265 args
= SCM_CDR (args
);
274 SCM_DEFINE (scm_append_x
, "append!", 0, 0, 1,
276 "A destructive version of @code{append} (@pxref{Pairs and\n"
277 "Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n"
278 "of each list's final pair is changed to point to the head of\n"
279 "the next list, so no consing is performed. Return a pointer to\n"
281 #define FUNC_NAME s_scm_append_x
283 SCM_VALIDATE_REST_ARGUMENT (lists
);
285 if (SCM_NULLP (lists
)) {
288 SCM arg
= SCM_CAR (lists
);
289 lists
= SCM_CDR (lists
);
290 if (SCM_NULLP (lists
)) {
292 } else if (!SCM_NULL_OR_NIL_P (arg
)) {
293 SCM_VALIDATE_CONS (SCM_ARG1
, arg
);
294 SCM_SETCDR (scm_last_pair (arg
), scm_append_x (lists
));
303 SCM_DEFINE (scm_last_pair
, "last-pair", 1, 0, 0,
305 "Return a pointer to the last pair in @var{lst}, signalling an error if\n"
306 "@var{lst} is circular.")
307 #define FUNC_NAME s_scm_last_pair
312 if (SCM_NULL_OR_NIL_P (lst
))
315 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
317 SCM ahead
= SCM_CDR(hare
);
318 if (SCM_NCONSP(ahead
)) return hare
;
320 ahead
= SCM_CDR(hare
);
321 if (SCM_NCONSP(ahead
)) return hare
;
323 tortoise
= SCM_CDR(tortoise
);
325 while (! SCM_EQ_P (hare
, tortoise
));
326 SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst
));
331 /* reversing lists */
333 SCM_DEFINE (scm_reverse
, "reverse", 1, 0, 0,
335 "Return a new list that contains the elements of @var{lst} but\n"
337 #define FUNC_NAME s_scm_reverse
339 SCM result
= SCM_EOL
;
344 if (SCM_NULL_OR_NIL_P(hare
)) return result
;
345 SCM_ASSERT(SCM_CONSP(hare
), lst
, 1, FUNC_NAME
);
346 result
= scm_cons (SCM_CAR (hare
), result
);
347 hare
= SCM_CDR (hare
);
348 if (SCM_NULL_OR_NIL_P(hare
)) return result
;
349 SCM_ASSERT(SCM_CONSP(hare
), lst
, 1, FUNC_NAME
);
350 result
= scm_cons (SCM_CAR (hare
), result
);
351 hare
= SCM_CDR (hare
);
352 tortoise
= SCM_CDR (tortoise
);
354 while (! SCM_EQ_P (hare
, tortoise
));
355 SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst
));
359 SCM_DEFINE (scm_reverse_x
, "reverse!", 1, 1, 0,
360 (SCM lst
, SCM new_tail
),
361 "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
362 "The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is\n"
363 "modified to point to the previous list element. Return a pointer to the\n"
364 "head of the reversed list.\n\n"
365 "Caveat: because the list is modified in place, the tail of the original\n"
366 "list now becomes its head, and the head of the original list now becomes\n"
367 "the tail. Therefore, the @var{lst} symbol to which the head of the\n"
368 "original list was bound now points to the tail. To ensure that the head\n"
369 "of the modified list is not lost, it is wise to save the return value of\n"
371 #define FUNC_NAME s_scm_reverse_x
373 SCM_VALIDATE_LIST (1, lst
);
374 if (SCM_UNBNDP (new_tail
))
377 SCM_VALIDATE_LIST (2, new_tail
);
379 while (!SCM_NULL_OR_NIL_P (lst
))
381 SCM old_tail
= SCM_CDR (lst
);
382 SCM_SETCDR (lst
, new_tail
);
392 /* indexing lists by element number */
394 SCM_DEFINE (scm_list_ref
, "list-ref", 2, 0, 0,
396 "Return the @var{k}th element from @var{list}.")
397 #define FUNC_NAME s_scm_list_ref
401 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
402 while (SCM_CONSP (lst
)) {
404 return SCM_CAR (lst
);
410 if (SCM_NULL_OR_NIL_P (lst
))
411 SCM_OUT_OF_RANGE (2, k
);
413 SCM_WRONG_TYPE_ARG (1, list
);
418 SCM_DEFINE (scm_list_set_x
, "list-set!", 3, 0, 0,
419 (SCM list
, SCM k
, SCM val
),
420 "Set the @var{k}th element of @var{list} to @var{val}.")
421 #define FUNC_NAME s_scm_list_set_x
425 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
426 while (SCM_CONSP (lst
)) {
428 SCM_SETCAR (lst
, val
);
435 if (SCM_NULL_OR_NIL_P (lst
))
436 SCM_OUT_OF_RANGE (2, k
);
438 SCM_WRONG_TYPE_ARG (1, list
);
443 SCM_REGISTER_PROC(s_list_cdr_ref
, "list-cdr-ref", 2, 0, 0, scm_list_tail
);
445 SCM_DEFINE (scm_list_tail
, "list-tail", 2, 0, 0,
447 "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
448 "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
449 "The first element of the list is considered to be element 0.\n\n"
450 "@code{list-tail} and @code{list-cdr-ref} are identical. It may help to\n"
451 "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
452 "or returning the results of cdring @var{k} times down @var{lst}.")
453 #define FUNC_NAME s_scm_list_tail
456 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
458 SCM_VALIDATE_CONS (1,lst
);
466 SCM_DEFINE (scm_list_cdr_set_x
, "list-cdr-set!", 3, 0, 0,
467 (SCM list
, SCM k
, SCM val
),
468 "Set the @var{k}th cdr of @var{list} to @var{val}.")
469 #define FUNC_NAME s_scm_list_cdr_set_x
473 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
474 while (SCM_CONSP (lst
)) {
476 SCM_SETCDR (lst
, val
);
483 if (SCM_NULL_OR_NIL_P (lst
))
484 SCM_OUT_OF_RANGE (2, k
);
486 SCM_WRONG_TYPE_ARG (1, list
);
492 /* copying lists, perhaps partially */
494 SCM_DEFINE (scm_list_head
, "list-head", 2, 0, 0,
496 "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
498 #define FUNC_NAME s_scm_list_head
504 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
509 SCM_VALIDATE_CONS (1,lst
);
510 *pos
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
511 pos
= SCM_CDRLOC (*pos
);
519 SCM_DEFINE (scm_list_copy
, "list-copy", 1, 0, 0,
521 "Return a (newly-created) copy of @var{lst}.")
522 #define FUNC_NAME s_scm_list_copy
528 SCM_VALIDATE_LIST (1, lst
);
534 while (SCM_CONSP (from_here
))
537 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
539 fill_here
= SCM_CDRLOC (c
);
540 from_here
= SCM_CDR (from_here
);
547 /* membership tests (memq, memv, etc.) */
549 /* The function scm_c_memq returns the first sublist of list whose car is
550 * 'eq?' obj, where the sublists of list are the non-empty lists returned by
551 * (list-tail list k) for k less than the length of list. If obj does not
552 * occur in list, then #f (not the empty list) is returned.
553 * List must be a proper list, otherwise scm_c_memq may crash or loop
557 scm_c_memq (SCM obj
, SCM list
)
559 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR (list
))
561 if (SCM_EQ_P (SCM_CAR (list
), obj
))
568 SCM_DEFINE (scm_memq
, "memq", 2, 0, 0,
570 "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
571 "to @var{x} where the sublists of @var{lst} are the non-empty\n"
572 "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
573 "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
574 "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
576 #define FUNC_NAME s_scm_memq
578 SCM_VALIDATE_LIST (2, lst
);
579 return scm_c_memq (x
, lst
);
584 SCM_DEFINE (scm_memv
, "memv", 2, 0, 0,
586 "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
587 "to @var{x} where the sublists of @var{lst} are the non-empty\n"
588 "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
589 "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
590 "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
592 #define FUNC_NAME s_scm_memv
594 SCM_VALIDATE_LIST (2, lst
);
595 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
597 if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst
), x
)))
605 SCM_DEFINE (scm_member
, "member", 2, 0, 0,
607 "Return the first sublist of @var{lst} whose car is\n"
608 "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
609 "the non-empty lists returned by @code{(list-tail @var{lst}\n"
610 "@var{k})} for @var{k} less than the length of @var{lst}. If\n"
611 "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
612 "empty list) is returned.")
613 #define FUNC_NAME s_scm_member
615 SCM_VALIDATE_LIST (2, lst
);
616 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
618 if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst
), x
)))
626 /* deleting elements from a list (delq, etc.) */
628 SCM_DEFINE (scm_delq_x
, "delq!", 2, 0, 0,
630 "@deffnx {Scheme Procedure} delv! item lst\n"
631 "@deffnx {Scheme Procedure} delete! item lst\n"
632 "These procedures are destructive versions of @code{delq}, @code{delv}\n"
633 "and @code{delete}: they modify the pointers in the existing @var{lst}\n"
634 "rather than creating a new list. Caveat evaluator: Like other\n"
635 "destructive list functions, these functions cannot modify the binding of\n"
636 "@var{lst}, and so cannot be used to delete the first element of\n"
637 "@var{lst} destructively.")
638 #define FUNC_NAME s_scm_delq_x
643 for (prev
= &lst
, walk
= lst
;
645 walk
= SCM_CDR (walk
))
647 if (SCM_EQ_P (SCM_CAR (walk
), item
))
648 *prev
= SCM_CDR (walk
);
650 prev
= SCM_CDRLOC (walk
);
658 SCM_DEFINE (scm_delv_x
, "delv!", 2, 0, 0,
660 "Destructively remove all elements from @var{lst} that are\n"
661 "@code{eqv?} to @var{item}.")
662 #define FUNC_NAME s_scm_delv_x
667 for (prev
= &lst
, walk
= lst
;
669 walk
= SCM_CDR (walk
))
671 if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk
), item
)))
672 *prev
= SCM_CDR (walk
);
674 prev
= SCM_CDRLOC (walk
);
683 SCM_DEFINE (scm_delete_x
, "delete!", 2, 0, 0,
685 "Destructively remove all elements from @var{lst} that are\n"
686 "@code{equal?} to @var{item}.")
687 #define FUNC_NAME s_scm_delete_x
692 for (prev
= &lst
, walk
= lst
;
694 walk
= SCM_CDR (walk
))
696 if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk
), item
)))
697 *prev
= SCM_CDR (walk
);
699 prev
= SCM_CDRLOC (walk
);
710 SCM_DEFINE (scm_delq
, "delq", 2, 0, 0,
712 "Return a newly-created copy of @var{lst} with elements\n"
713 "@code{eq?} to @var{item} removed. This procedure mirrors\n"
714 "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
715 "@var{item} with @code{eq?}.")
716 #define FUNC_NAME s_scm_delq
718 SCM copy
= scm_list_copy (lst
);
719 return scm_delq_x (item
, copy
);
723 SCM_DEFINE (scm_delv
, "delv", 2, 0, 0,
725 "Return a newly-created copy of @var{lst} with elements\n"
726 "@code{eqv?} to @var{item} removed. This procedure mirrors\n"
727 "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
728 "@var{item} with @code{eqv?}.")
729 #define FUNC_NAME s_scm_delv
731 SCM copy
= scm_list_copy (lst
);
732 return scm_delv_x (item
, copy
);
736 SCM_DEFINE (scm_delete
, "delete", 2, 0, 0,
738 "Return a newly-created copy of @var{lst} with elements\n"
739 "@code{equal?} to @var{item} removed. This procedure mirrors\n"
740 "@code{member}: @code{delete} compares elements of @var{lst}\n"
741 "against @var{item} with @code{equal?}.")
742 #define FUNC_NAME s_scm_delete
744 SCM copy
= scm_list_copy (lst
);
745 return scm_delete_x (item
, copy
);
750 SCM_DEFINE (scm_delq1_x
, "delq1!", 2, 0, 0,
752 "Like @code{delq!}, but only deletes the first occurrence of\n"
753 "@var{item} from @var{lst}. Tests for equality using\n"
754 "@code{eq?}. See also @code{delv1!} and @code{delete1!}.")
755 #define FUNC_NAME s_scm_delq1_x
760 for (prev
= &lst
, walk
= lst
;
762 walk
= SCM_CDR (walk
))
764 if (SCM_EQ_P (SCM_CAR (walk
), item
))
766 *prev
= SCM_CDR (walk
);
770 prev
= SCM_CDRLOC (walk
);
778 SCM_DEFINE (scm_delv1_x
, "delv1!", 2, 0, 0,
780 "Like @code{delv!}, but only deletes the first occurrence of\n"
781 "@var{item} from @var{lst}. Tests for equality using\n"
782 "@code{eqv?}. See also @code{delq1!} and @code{delete1!}.")
783 #define FUNC_NAME s_scm_delv1_x
788 for (prev
= &lst
, walk
= lst
;
790 walk
= SCM_CDR (walk
))
792 if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk
), item
)))
794 *prev
= SCM_CDR (walk
);
798 prev
= SCM_CDRLOC (walk
);
806 SCM_DEFINE (scm_delete1_x
, "delete1!", 2, 0, 0,
808 "Like @code{delete!}, but only deletes the first occurrence of\n"
809 "@var{item} from @var{lst}. Tests for equality using\n"
810 "@code{equal?}. See also @code{delq1!} and @code{delv1!}.")
811 #define FUNC_NAME s_scm_delete1_x
816 for (prev
= &lst
, walk
= lst
;
818 walk
= SCM_CDR (walk
))
820 if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk
), item
)))
822 *prev
= SCM_CDR (walk
);
826 prev
= SCM_CDRLOC (walk
);
838 #ifndef SCM_MAGIC_SNARFER
839 #include "libguile/list.x"