6493df8de265e1eab58205afcc197eaabc4f6e08
1 /* Copyright (C) 1995,1996,1997, 2000 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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
47 #include "libguile/_scm.h"
48 #include "libguile/eq.h"
50 #include "libguile/validate.h"
51 #include "libguile/list.h"
55 #define var_start(x, y) va_start(x, y)
58 #define var_start(x, y) va_start(x)
65 scm_listify (SCM elt
, ...)
72 while (! SCM_UNBNDP (elt
))
74 *pos
= scm_cons (elt
, SCM_EOL
);
75 pos
= SCM_CDRLOC (*pos
);
76 elt
= va_arg (foo
, SCM
);
82 SCM_DEFINE (scm_list
, "list", 0, 0, 1,
84 "Return a list containing OBJS, the arguments to `list'.")
85 #define FUNC_NAME s_scm_list
92 #if (SCM_DEBUG_DEPRECATED == 0)
94 SCM_REGISTER_PROC (s_list_star
, "list*", 1, 0, 1, scm_cons_star
);
96 #endif /* SCM_DEBUG_DEPRECATED == 0 */
98 SCM_DEFINE (scm_cons_star
, "cons*", 1, 0, 1,
100 "Like `list', but the last arg provides the tail of the constructed list,\n"
101 "returning (cons ARG1 (cons ARG2 (cons ... ARGn))).\n"
102 "Requires at least one argument. If given one argument, that argument\n"
103 "is returned as result.\n"
104 "This function is called `list*' in some other Schemes and in Common LISP.")
105 #define FUNC_NAME s_scm_cons_star
107 SCM_VALIDATE_REST_ARGUMENT (rest
);
108 if (!SCM_NULLP (rest
))
110 SCM prev
= arg
= scm_cons (arg
, rest
);
111 while (SCM_NNULLP (SCM_CDR (rest
)))
114 rest
= SCM_CDR (rest
);
116 SCM_SETCDR (prev
, SCM_CAR (rest
));
124 /* general questions about lists --- null?, list?, length, etc. */
126 SCM_DEFINE (scm_null_p
, "null?", 1, 0, 0,
128 "Return #t iff X is the empty list, else #f.")
129 #define FUNC_NAME s_scm_null_p
131 return SCM_BOOL (SCM_NULLP (x
));
136 SCM_DEFINE (scm_list_p
, "list?", 1, 0, 0,
138 "Return #t iff X is a proper list, else #f.")
139 #define FUNC_NAME s_scm_list_p
141 return SCM_BOOL (scm_ilength (x
) >= 0);
146 /* Return the length of SX, or -1 if it's not a proper list.
147 This uses the "tortoise and hare" algorithm to detect "infinitely
148 long" lists (i.e. lists with cycles in their cdrs), and returns -1
149 if it does find one. */
158 if (SCM_NULLP(hare
)) return i
;
159 if (SCM_NCONSP(hare
)) return -1;
160 hare
= SCM_CDR(hare
);
162 if (SCM_NULLP(hare
)) return i
;
163 if (SCM_NCONSP(hare
)) return -1;
164 hare
= SCM_CDR(hare
);
166 /* For every two steps the hare takes, the tortoise takes one. */
167 tortoise
= SCM_CDR(tortoise
);
169 while (! SCM_EQ_P (hare
, tortoise
));
171 /* If the tortoise ever catches the hare, then the list must contain
177 SCM_DEFINE (scm_length
, "length", 1, 0, 0,
179 "Return the number of elements in list LST.")
180 #define FUNC_NAME s_scm_length
183 SCM_VALIDATE_LIST_COPYLEN (1,lst
,i
);
184 return SCM_MAKINUM (i
);
190 /* appending lists */
192 SCM_DEFINE (scm_append
, "append", 0, 0, 1,
194 "Returns a list consisting of the elements of the first LIST\n"
195 "followed by the elements of the other LISTs.\n\n"
197 " (append '(x) '(y)) => (x y)\n"
198 " (append '(a) '(b c d)) => (a b c d)\n"
199 " (append '(a (b)) '((c))) => (a (b) (c))\n"
201 "The resulting list is always newly allocated, except that it shares\n"
202 "structure with the last LIST argument. The last argument may\n"
203 "actually be any object; an improper list results if the last\n"
204 "argument is not a proper list.\n\n"
206 " (append '(a b) '(c . d)) => (a b c . d)\n"
207 " (append '() 'a) => a\n"
209 #define FUNC_NAME s_scm_append
211 SCM_VALIDATE_REST_ARGUMENT (args
);
212 if (SCM_NULLP (args
)) {
217 SCM arg
= SCM_CAR (args
);
218 args
= SCM_CDR (args
);
219 while (!SCM_NULLP (args
)) {
220 while (SCM_CONSP (arg
)) {
221 *lloc
= scm_cons (SCM_CAR (arg
), SCM_EOL
);
222 lloc
= SCM_CDRLOC (*lloc
);
225 SCM_VALIDATE_NULL (SCM_ARGn
, arg
);
226 arg
= SCM_CAR (args
);
227 args
= SCM_CDR (args
);
236 SCM_DEFINE (scm_append_x
, "append!", 0, 0, 1,
238 "A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,\n"
239 "The Revised^4 Report on Scheme}). The cdr field of each list's final\n"
240 "pair is changed to point to the head of the next list, so no consing is\n"
241 "performed. Return a pointer to the mutated list.")
242 #define FUNC_NAME s_scm_append_x
244 SCM_VALIDATE_REST_ARGUMENT (args
);
246 if (SCM_NULLP (args
)) {
249 SCM arg
= SCM_CAR (args
);
250 args
= SCM_CDR (args
);
251 if (SCM_NULLP (args
)) {
253 } else if (!SCM_NULLP (arg
)) {
254 SCM_VALIDATE_CONS (SCM_ARG1
, arg
);
255 SCM_SETCDR (scm_last_pair (arg
), scm_append_x (args
));
264 SCM_DEFINE (scm_last_pair
, "last-pair", 1, 0, 0,
266 "Return a pointer to the last pair in @var{lst}, signalling an error if\n"
267 "@var{lst} is circular.")
268 #define FUNC_NAME s_scm_last_pair
276 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
278 SCM ahead
= SCM_CDR(hare
);
279 if (SCM_NCONSP(ahead
)) return hare
;
281 ahead
= SCM_CDR(hare
);
282 if (SCM_NCONSP(ahead
)) return hare
;
284 tortoise
= SCM_CDR(tortoise
);
286 while (! SCM_EQ_P (hare
, tortoise
));
287 SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst
));
292 /* reversing lists */
294 SCM_DEFINE (scm_reverse
, "reverse", 1, 0, 0,
296 "Return a new list that contains the elements of LST but in reverse order.")
297 #define FUNC_NAME s_scm_reverse
299 SCM result
= SCM_EOL
;
304 if (SCM_NULLP(hare
)) return result
;
305 SCM_ASSERT(SCM_CONSP(hare
), lst
, 1, FUNC_NAME
);
306 result
= scm_cons (SCM_CAR (hare
), result
);
307 hare
= SCM_CDR (hare
);
308 if (SCM_NULLP(hare
)) return result
;
309 SCM_ASSERT(SCM_CONSP(hare
), lst
, 1, FUNC_NAME
);
310 result
= scm_cons (SCM_CAR (hare
), result
);
311 hare
= SCM_CDR (hare
);
312 tortoise
= SCM_CDR (tortoise
);
314 while (! SCM_EQ_P (hare
, tortoise
));
315 SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst
));
319 SCM_DEFINE (scm_reverse_x
, "reverse!", 1, 1, 0,
320 (SCM lst
, SCM new_tail
),
321 "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs,\n"
322 "The Revised^4 Report on Scheme}). The cdr of each cell in @var{lst} is\n"
323 "modified to point to the previous list element. Return a pointer to the\n"
324 "head of the reversed list.\n\n"
325 "Caveat: because the list is modified in place, the tail of the original\n"
326 "list now becomes its head, and the head of the original list now becomes\n"
327 "the tail. Therefore, the @var{lst} symbol to which the head of the\n"
328 "original list was bound now points to the tail. To ensure that the head\n"
329 "of the modified list is not lost, it is wise to save the return value of\n"
331 #define FUNC_NAME s_scm_reverse_x
333 SCM_ASSERT (scm_ilength (lst
) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
334 if (SCM_UNBNDP (new_tail
))
337 SCM_ASSERT (scm_ilength (new_tail
) >= 0, new_tail
, SCM_ARG2
, FUNC_NAME
);
339 while (SCM_NNULLP (lst
))
341 SCM old_tail
= SCM_CDR (lst
);
342 SCM_SETCDR (lst
, new_tail
);
352 /* indexing lists by element number */
354 SCM_DEFINE (scm_list_ref
, "list-ref", 2, 0, 0,
356 "Return the Kth element from LIST.")
357 #define FUNC_NAME s_scm_list_ref
361 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
362 while (SCM_CONSP (lst
)) {
364 return SCM_CAR (lst
);
371 SCM_OUT_OF_RANGE (2, k
);
373 SCM_WRONG_TYPE_ARG (1, list
);
378 SCM_DEFINE (scm_list_set_x
, "list-set!", 3, 0, 0,
379 (SCM list
, SCM k
, SCM val
),
380 "Set the @var{k}th element of @var{list} to @var{val}.")
381 #define FUNC_NAME s_scm_list_set_x
385 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
386 while (SCM_CONSP (lst
)) {
388 SCM_SETCAR (lst
, val
);
396 SCM_OUT_OF_RANGE (2, k
);
398 SCM_WRONG_TYPE_ARG (1, list
);
403 SCM_REGISTER_PROC(s_list_cdr_ref
, "list-cdr-ref", 2, 0, 0, scm_list_tail
);
405 SCM_DEFINE (scm_list_tail
, "list-tail", 2, 0, 0,
407 "@deffnx primitive list-cdr-ref lst k\n"
408 "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
409 "The first element of the list is considered to be element 0.\n\n"
410 "@code{list-tail} and @code{list-cdr-ref} are identical. It may help to\n"
411 "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
412 "or returning the results of cdring @var{k} times down @var{lst}.")
413 #define FUNC_NAME s_scm_list_tail
416 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
418 SCM_VALIDATE_CONS (1,lst
);
426 SCM_DEFINE (scm_list_cdr_set_x
, "list-cdr-set!", 3, 0, 0,
427 (SCM list
, SCM k
, SCM val
),
428 "Set the @var{k}th cdr of @var{list} to @var{val}.")
429 #define FUNC_NAME s_scm_list_cdr_set_x
433 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
434 while (SCM_CONSP (lst
)) {
436 SCM_SETCDR (lst
, val
);
444 SCM_OUT_OF_RANGE (2, k
);
446 SCM_WRONG_TYPE_ARG (1, list
);
452 /* copying lists, perhaps partially */
454 SCM_DEFINE (scm_list_head
, "list-head", 2, 0, 0,
456 "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
458 #define FUNC_NAME s_scm_list_head
464 SCM_VALIDATE_INUM_MIN_COPY (2,k
,0,i
);
469 SCM_VALIDATE_CONS (1,lst
);
470 *pos
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
471 pos
= SCM_CDRLOC (*pos
);
479 SCM_DEFINE (scm_list_copy
, "list-copy", 1, 0, 0,
481 "Return a (newly-created) copy of @var{lst}.")
482 #define FUNC_NAME s_scm_list_copy
488 SCM_VALIDATE_LIST (1, lst
);
494 while (SCM_CONSP (from_here
))
497 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
499 fill_here
= SCM_CDRLOC (c
);
500 from_here
= SCM_CDR (from_here
);
507 /* membership tests (memq, memv, etc.) */
509 #if SCM_DEBUG_DEPRECATED == 0
511 SCM_DEFINE (scm_sloppy_memq
, "sloppy-memq", 2, 0, 0,
513 "This procedure behaves like @code{memq}, but does no type or error checking.\n"
514 "Its use is recommended only in writing Guile internals,\n"
515 "not for high-level Scheme programs.")
516 #define FUNC_NAME s_scm_sloppy_memq
518 for(; SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
520 if (SCM_EQ_P (SCM_CAR (lst
), x
))
528 SCM_DEFINE (scm_sloppy_memv
, "sloppy-memv", 2, 0, 0,
530 "This procedure behaves like @code{memv}, but does no type or error checking.\n"
531 "Its use is recommended only in writing Guile internals,\n"
532 "not for high-level Scheme programs.")
533 #define FUNC_NAME s_scm_sloppy_memv
535 for(; SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
537 if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst
), x
)))
545 SCM_DEFINE (scm_sloppy_member
, "sloppy-member", 2, 0, 0,
547 "This procedure behaves like @code{member}, but does no type or error checking.\n"
548 "Its use is recommended only in writing Guile internals,\n"
549 "not for high-level Scheme programs.")
550 #define FUNC_NAME s_scm_sloppy_member
552 for(; SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
554 if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst
), x
)))
561 #endif /* DEPRECATED */
563 /* The function scm_c_memq returns the first sublist of list whose car is
564 * 'eq?' obj, where the sublists of list are the non-empty lists returned by
565 * (list-tail list k) for k less than the length of list. If obj does not
566 * occur in list, then #f (not the empty list) is returned. (r5rs)
567 * List must be a proper list, otherwise scm_c_memq may crash or loop
571 scm_c_memq (SCM obj
, SCM list
)
573 for (; !SCM_NULLP (list
); list
= SCM_CDR (list
))
575 if (SCM_EQ_P (SCM_CAR (list
), obj
))
582 SCM_DEFINE (scm_memq
, "memq", 2, 0, 0,
584 "Return the first sublist of LST whose car is `eq?' to X\n"
585 "where the sublists of LST are the non-empty lists returned\n"
586 "by `(list-tail LST K)' for K less than the length of LST. If\n"
587 "X does not occur in LST, then `#f' (not the empty list) is\n"
589 #define FUNC_NAME s_scm_memq
591 SCM_VALIDATE_LIST (2, lst
);
592 return scm_c_memq (x
, lst
);
598 SCM_DEFINE (scm_memv
, "memv", 2, 0, 0,
600 "Return the first sublist of LST whose car is `eqv?' to X\n"
601 "where the sublists of LST are the non-empty lists returned\n"
602 "by `(list-tail LST K)' for K less than the length of LST. If\n"
603 "X does not occur in LST, then `#f' (not the empty list) is\n"
605 #define FUNC_NAME s_scm_memv
607 SCM_VALIDATE_LIST (2, lst
);
608 for (; !SCM_NULLP (lst
); lst
= SCM_CDR (lst
))
610 if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst
), x
)))
618 SCM_DEFINE (scm_member
, "member", 2, 0, 0,
620 "Return the first sublist of LST whose car is `equal?' to X\n"
621 "where the sublists of LST are the non-empty lists returned\n"
622 "by `(list-tail LST K)' for K less than the length of LST. If\n"
623 "X does not occur in LST, then `#f' (not the empty list) is\n"
625 #define FUNC_NAME s_scm_member
627 SCM_VALIDATE_LIST (2, lst
);
628 for (; !SCM_NULLP (lst
); lst
= SCM_CDR (lst
))
630 if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst
), x
)))
639 /* deleting elements from a list (delq, etc.) */
641 SCM_DEFINE (scm_delq_x
, "delq!", 2, 0, 0,
643 "@deffnx primitive delv! item lst\n"
644 "@deffnx primitive delete! item lst\n"
645 "These procedures are destructive versions of @code{delq}, @code{delv}\n"
646 "and @code{delete}: they modify the pointers in the existing @var{lst}\n"
647 "rather than creating a new list. Caveat evaluator: Like other\n"
648 "destructive list functions, these functions cannot modify the binding of\n"
649 "@var{lst}, and so cannot be used to delete the first element of\n"
650 "@var{lst} destructively.")
651 #define FUNC_NAME s_scm_delq_x
656 for (prev
= &lst
, walk
= lst
;
658 walk
= SCM_CDR (walk
))
660 if (SCM_EQ_P (SCM_CAR (walk
), item
))
661 *prev
= SCM_CDR (walk
);
663 prev
= SCM_CDRLOC (walk
);
671 SCM_DEFINE (scm_delv_x
, "delv!", 2, 0, 0,
673 "Destructively remove all elements from LST that are `eqv?' to ITEM.")
674 #define FUNC_NAME s_scm_delv_x
679 for (prev
= &lst
, walk
= lst
;
681 walk
= SCM_CDR (walk
))
683 if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk
), item
)))
684 *prev
= SCM_CDR (walk
);
686 prev
= SCM_CDRLOC (walk
);
695 SCM_DEFINE (scm_delete_x
, "delete!", 2, 0, 0,
697 "Destructively remove all elements from LST that are `equal?' to ITEM.")
698 #define FUNC_NAME s_scm_delete_x
703 for (prev
= &lst
, walk
= lst
;
705 walk
= SCM_CDR (walk
))
707 if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk
), item
)))
708 *prev
= SCM_CDR (walk
);
710 prev
= SCM_CDRLOC (walk
);
721 SCM_DEFINE (scm_delq
, "delq", 2, 0, 0,
723 "Return a newly-created copy of @var{lst} with elements `eq?' to @var{item} removed.\n"
724 "This procedure mirrors @code{memq}:\n"
725 "@code{delq} compares elements of @var{lst} against @var{item} with\n"
727 #define FUNC_NAME s_scm_delq
729 SCM copy
= scm_list_copy (lst
);
730 return scm_delq_x (item
, copy
);
734 SCM_DEFINE (scm_delv
, "delv", 2, 0, 0,
736 "Return a newly-created copy of @var{lst} with elements `eqv?' to @var{item} removed.\n"
737 "This procedure mirrors @code{memv}:\n"
738 "@code{delv} compares elements of @var{lst} against @var{item} with\n"
740 #define FUNC_NAME s_scm_delv
742 SCM copy
= scm_list_copy (lst
);
743 return scm_delv_x (item
, copy
);
747 SCM_DEFINE (scm_delete
, "delete", 2, 0, 0,
749 "Return a newly-created copy of @var{lst} with elements `equal?' to @var{item} removed.\n"
750 "This procedure mirrors @code{member}:\n"
751 "@code{delete} compares elements of @var{lst} against @var{item} with\n"
753 #define FUNC_NAME s_scm_delete
755 SCM copy
= scm_list_copy (lst
);
756 return scm_delete_x (item
, copy
);
761 SCM_DEFINE (scm_delq1_x
, "delq1!", 2, 0, 0,
763 "Like `delq!', but only deletes the first occurrence of ITEM from LST.\n"
764 "Tests for equality using `eq?'. See also `delv1!' and `delete1!'.")
765 #define FUNC_NAME s_scm_delq1_x
770 for (prev
= &lst
, walk
= lst
;
772 walk
= SCM_CDR (walk
))
774 if (SCM_EQ_P (SCM_CAR (walk
), item
))
776 *prev
= SCM_CDR (walk
);
780 prev
= SCM_CDRLOC (walk
);
788 SCM_DEFINE (scm_delv1_x
, "delv1!", 2, 0, 0,
790 "Like `delv!', but only deletes the first occurrence of ITEM from LST.\n"
791 "Tests for equality using `eqv?'. See also `delq1!' and `delete1!'.")
792 #define FUNC_NAME s_scm_delv1_x
797 for (prev
= &lst
, walk
= lst
;
799 walk
= SCM_CDR (walk
))
801 if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk
), item
)))
803 *prev
= SCM_CDR (walk
);
807 prev
= SCM_CDRLOC (walk
);
815 SCM_DEFINE (scm_delete1_x
, "delete1!", 2, 0, 0,
817 "Like `delete!', but only deletes the first occurrence of ITEM from LST.\n"
818 "Tests for equality using `equal?'. See also `delq1!' and `delv1!'.")
819 #define FUNC_NAME s_scm_delete1_x
824 for (prev
= &lst
, walk
= lst
;
826 walk
= SCM_CDR (walk
))
828 if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk
), item
)))
830 *prev
= SCM_CDR (walk
);
834 prev
= SCM_CDRLOC (walk
);
846 #ifndef SCM_MAGIC_SNARFER
847 #include "libguile/list.x"