1 /* Copyright (C) 1995,1996,1997 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. */
50 #define var_start(x, y) va_start(x, y)
53 #define var_start(x, y) va_start(x)
59 /* SCM_P won't help us deal with varargs here. */
62 scm_listify (SCM elt
, ...)
65 scm_listify (elt
, va_alist
)
77 while (elt
!= SCM_UNDEFINED
)
79 *pos
= scm_cons (elt
, SCM_EOL
);
80 pos
= SCM_CDRLOC (*pos
);
81 elt
= va_arg (foo
, SCM
);
87 SCM_PROC(s_list
, "list", 0, 0, 1, scm_list
);
98 /* general questions about lists --- null?, list?, length, etc. */
100 SCM_PROC(s_null_p
, "null?", 1, 0, 0, scm_null_p
);
105 return SCM_NULLP(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
108 SCM_PROC(s_list_p
, "list?", 1, 0, 0, scm_list_p
);
113 if (scm_ilength(x
)<0)
120 /* Return the length of SX, or -1 if it's not a proper list.
121 This uses the "tortoise and hare" algorithm to detect "infinitely
122 long" lists (i.e. lists with cycles in their cdrs), and returns -1
123 if it does find one. */
129 register SCM tortoise
= sx
;
130 register SCM hare
= sx
;
133 if SCM_IMP(hare
) return SCM_NULLP(hare
) ? i
: -1;
134 if SCM_NCONSP(hare
) return -1;
135 hare
= SCM_CDR(hare
);
137 if SCM_IMP(hare
) return SCM_NULLP(hare
) ? i
: -1;
138 if SCM_NCONSP(hare
) return -1;
139 hare
= SCM_CDR(hare
);
141 /* For every two steps the hare takes, the tortoise takes one. */
142 tortoise
= SCM_CDR(tortoise
);
144 while (hare
!= tortoise
);
146 /* If the tortoise ever catches the hare, then the list must contain
151 SCM_PROC(s_length
, "length", 1, 0, 0, scm_length
);
158 SCM_ASSERT(i
>= 0, x
, SCM_ARG1
, s_length
);
159 return SCM_MAKINUM (i
);
164 /* appending lists */
166 SCM_PROC (s_append
, "append", 0, 0, 1, scm_append
);
172 SCM
*lloc
= &res
, arg
;
174 SCM_ASSERT(SCM_NULLP(args
), args
, SCM_ARGn
, s_append
);
177 SCM_ASSERT(SCM_CONSP(args
), args
, SCM_ARGn
, s_append
);
180 args
= SCM_CDR(args
);
183 SCM_ASSERT(SCM_NULLP(args
), args
, SCM_ARGn
, s_append
);
186 SCM_ASSERT(SCM_CONSP(args
), args
, SCM_ARGn
, s_append
);
187 for(;SCM_NIMP(arg
);arg
= SCM_CDR(arg
)) {
188 SCM_ASSERT(SCM_CONSP(arg
), arg
, SCM_ARGn
, s_append
);
189 *lloc
= scm_cons(SCM_CAR(arg
), SCM_EOL
);
190 lloc
= SCM_CDRLOC(*lloc
);
192 SCM_ASSERT(SCM_NULLP(arg
), arg
, SCM_ARGn
, s_append
);
197 SCM_PROC (s_append_x
, "append!", 0, 0, 1, scm_append_x
);
204 if SCM_NULLP(args
) return SCM_EOL
;
206 args
= SCM_CDR(args
);
207 if SCM_NULLP(args
) return arg
;
208 if SCM_NULLP(arg
) goto tail
;
209 SCM_ASSERT(SCM_NIMP(arg
) && SCM_CONSP(arg
), arg
, SCM_ARG1
, s_append_x
);
210 SCM_SETCDR (scm_last_pair (arg
), scm_append_x (args
));
215 SCM_PROC(s_last_pair
, "last-pair", 1, 0, 0, scm_last_pair
);
220 register SCM res
= sx
;
226 SCM_ASSERT(SCM_NIMP(res
) && SCM_CONSP(res
), res
, SCM_ARG1
, s_last_pair
);
229 if (SCM_IMP(x
) || SCM_NCONSP(x
)) return res
;
232 if (SCM_IMP(x
) || SCM_NCONSP(x
)) return res
;
235 SCM_ASSERT(x
!= sx
, sx
, SCM_ARG1
, s_last_pair
);
240 /* reversing lists */
242 SCM_PROC (s_reverse
, "reverse", 1, 0, 0, scm_reverse
);
249 for(;SCM_NIMP(p
);p
= SCM_CDR(p
)) {
250 SCM_ASSERT(SCM_CONSP(p
), lst
, SCM_ARG1
, s_reverse
);
251 res
= scm_cons(SCM_CAR(p
), res
);
253 SCM_ASSERT(SCM_NULLP(p
), lst
, SCM_ARG1
, s_reverse
);
257 SCM_PROC (s_reverse_x
, "reverse!", 1, 1, 0, scm_reverse_x
);
259 scm_reverse_x (lst
, newtail
)
264 if (newtail
== SCM_UNDEFINED
)
268 if (!(SCM_NIMP (lst
) && SCM_CONSP (lst
)))
271 old_tail
= SCM_CDR (lst
);
272 SCM_SETCDR (lst
, newtail
);
273 if (SCM_NULLP (old_tail
))
283 /* indexing lists by element number */
285 SCM_PROC(s_list_ref
, "list-ref", 2, 0, 0, scm_list_ref
);
292 SCM_ASSERT(SCM_INUMP(k
), k
, SCM_ARG2
, s_list_ref
);
294 SCM_ASSERT(i
>= 0, k
, SCM_ARG2
, s_list_ref
);
296 SCM_ASRTGO(SCM_NIMP(lst
) && SCM_CONSP(lst
), erout
);
299 erout
: SCM_ASSERT(SCM_NIMP(lst
) && SCM_CONSP(lst
),
300 SCM_NULLP(lst
)?k
:lst
, SCM_NULLP(lst
)?SCM_OUTOFRANGE
:SCM_ARG1
, s_list_ref
);
304 SCM_PROC(s_list_set_x
, "list-set!", 3, 0, 0, scm_list_set_x
);
306 scm_list_set_x(lst
, k
, val
)
312 SCM_ASSERT(SCM_INUMP(k
), k
, SCM_ARG2
, s_list_set_x
);
314 SCM_ASSERT(i
>= 0, k
, SCM_ARG2
, s_list_set_x
);
316 SCM_ASRTGO(SCM_NIMP(lst
) && SCM_CONSP(lst
), erout
);
319 erout
: SCM_ASSERT(SCM_NIMP(lst
) && SCM_CONSP(lst
),
320 SCM_NULLP(lst
)?k
:lst
, SCM_NULLP(lst
)?SCM_OUTOFRANGE
:SCM_ARG1
, s_list_set_x
);
321 SCM_SETCAR (lst
, val
);
326 SCM_PROC(s_list_cdr_ref
, "list-cdr-ref", 2, 0, 0, scm_list_tail
);
327 SCM_PROC(s_list_tail
, "list-tail", 2, 0, 0, scm_list_tail
);
329 scm_list_tail(lst
, k
)
334 SCM_ASSERT(SCM_INUMP(k
), k
, SCM_ARG2
, s_list_tail
);
337 SCM_ASSERT(SCM_NIMP(lst
) && SCM_CONSP(lst
), lst
, SCM_ARG1
, s_list_tail
);
344 SCM_PROC(s_list_cdr_set_x
, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x
);
346 scm_list_cdr_set_x(lst
, k
, val
)
352 SCM_ASSERT(SCM_INUMP(k
), k
, SCM_ARG2
, s_list_cdr_set_x
);
354 SCM_ASSERT(i
>= 0, k
, SCM_ARG2
, s_list_cdr_set_x
);
356 SCM_ASRTGO(SCM_NIMP(lst
) && SCM_CONSP(lst
), erout
);
359 erout
: SCM_ASSERT(SCM_NIMP(lst
) && SCM_CONSP(lst
),
360 SCM_NULLP(lst
)?k
:lst
, SCM_NULLP(lst
)?SCM_OUTOFRANGE
:SCM_ARG1
, s_list_cdr_set_x
);
361 SCM_SETCDR (lst
, val
);
367 /* copying lists, perhaps partially */
369 SCM_PROC(s_list_head
, "list-head", 2, 0, 0, scm_list_head
);
371 scm_list_head(lst
, k
)
379 SCM_ASSERT(SCM_INUMP(k
), k
, SCM_ARG2
, s_list_head
);
385 SCM_ASSERT(SCM_NIMP(lst
) && SCM_CONSP(lst
), lst
, SCM_ARG1
, s_list_head
);
386 *pos
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
387 pos
= SCM_CDRLOC (*pos
);
394 SCM_PROC (s_list_copy
, "list-copy", 1, 0, 0, scm_list_copy
);
407 while (SCM_NIMP (from_here
) && SCM_CONSP (from_here
))
410 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
412 fill_here
= SCM_CDRLOC (c
);
413 from_here
= SCM_CDR (from_here
);
419 /* membership tests (memq, memv, etc.) */
421 static void sloppy_mem_check
SCM_P ((SCM obj
, char * where
, char * why
));
423 SCM_PROC (s_sloppy_memq
, "sloppy-memq", 2, 0, 0, scm_sloppy_memq
);
425 scm_sloppy_memq(x
, lst
)
429 for(; SCM_NIMP(lst
) && SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
438 SCM_PROC (s_sloppy_memv
, "sloppy-memv", 2, 0, 0, scm_sloppy_memv
);
440 scm_sloppy_memv(x
, lst
)
444 for(; SCM_NIMP(lst
) && SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
446 if (SCM_BOOL_F
!= scm_eqv_p (SCM_CAR(lst
), x
))
453 SCM_PROC (s_sloppy_member
, "sloppy-member", 2, 0, 0, scm_sloppy_member
);
455 scm_sloppy_member (x
, lst
)
459 for(; SCM_NIMP(lst
) && SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
461 if (SCM_BOOL_F
!= scm_equal_p (SCM_CAR(lst
), x
))
469 SCM_PROC(s_memq
, "memq", 2, 0, 0, scm_memq
);
476 SCM_ASSERT (scm_ilength (lst
) >= 0, lst
, SCM_ARG2
, s_memq
);
477 answer
= scm_sloppy_memq (x
, lst
);
478 return (answer
== SCM_EOL
) ? SCM_BOOL_F
: answer
;
483 SCM_PROC(s_memv
, "memv", 2, 0, 0, scm_memv
);
490 SCM_ASSERT (scm_ilength (lst
) >= 0, lst
, SCM_ARG2
, s_memv
);
491 answer
= scm_sloppy_memv (x
, lst
);
492 return (answer
== SCM_EOL
) ? SCM_BOOL_F
: answer
;
496 SCM_PROC(s_member
, "member", 2, 0, 0, scm_member
);
503 SCM_ASSERT (scm_ilength (lst
) >= 0, lst
, SCM_ARG2
, s_member
);
504 answer
= scm_sloppy_member (x
, lst
);
505 return (answer
== SCM_EOL
) ? SCM_BOOL_F
: answer
;
510 /* deleting elements from a list (delq, etc.) */
512 SCM_PROC(s_delq_x
, "delq!", 2, 0, 0, scm_delq_x
);
514 scm_delq_x (item
, lst
)
521 for (prev
= &lst
, walk
= lst
;
522 SCM_NIMP (walk
) && SCM_CONSP (walk
);
523 walk
= SCM_CDR (walk
))
525 if (SCM_CAR (walk
) == item
)
526 *prev
= SCM_CDR (walk
);
528 prev
= SCM_CDRLOC (walk
);
535 SCM_PROC(s_delv_x
, "delv!", 2, 0, 0, scm_delv_x
);
537 scm_delv_x (item
, lst
)
544 for (prev
= &lst
, walk
= lst
;
545 SCM_NIMP (walk
) && SCM_CONSP (walk
);
546 walk
= SCM_CDR (walk
))
548 if (SCM_BOOL_F
!= scm_eqv_p (SCM_CAR (walk
), item
))
549 *prev
= SCM_CDR (walk
);
551 prev
= SCM_CDRLOC (walk
);
559 SCM_PROC(s_delete_x
, "delete!", 2, 0, 0, scm_delete_x
);
561 scm_delete_x (item
, lst
)
568 for (prev
= &lst
, walk
= lst
;
569 SCM_NIMP (walk
) && SCM_CONSP (walk
);
570 walk
= SCM_CDR (walk
))
572 if (SCM_BOOL_F
!= scm_equal_p (SCM_CAR (walk
), item
))
573 *prev
= SCM_CDR (walk
);
575 prev
= SCM_CDRLOC (walk
);
585 SCM_PROC (s_delq
, "delq", 2, 0, 0, scm_delq
);
593 copy
= scm_list_copy (lst
);
594 return scm_delq_x (item
, copy
);
597 SCM_PROC (s_delv
, "delv", 2, 0, 0, scm_delv
);
605 copy
= scm_list_copy (lst
);
606 return scm_delv_x (item
, copy
);
609 SCM_PROC (s_delete
, "delete", 2, 0, 0, scm_delete
);
611 scm_delete (item
, lst
)
617 copy
= scm_list_copy (lst
);
618 return scm_delete_x (item
, copy
);
622 SCM_PROC(s_delq1_x
, "delq1!", 2, 0, 0, scm_delq1_x
);
624 scm_delq1_x (item
, lst
)
631 for (prev
= &lst
, walk
= lst
;
632 SCM_NIMP (walk
) && SCM_CONSP (walk
);
633 walk
= SCM_CDR (walk
))
635 if (SCM_CAR (walk
) == item
)
637 *prev
= SCM_CDR (walk
);
641 prev
= SCM_CDRLOC (walk
);
648 SCM_PROC(s_delv1_x
, "delv1!", 2, 0, 0, scm_delv1_x
);
650 scm_delv1_x (item
, lst
)
657 for (prev
= &lst
, walk
= lst
;
658 SCM_NIMP (walk
) && SCM_CONSP (walk
);
659 walk
= SCM_CDR (walk
))
661 if (SCM_BOOL_F
!= scm_eqv_p (SCM_CAR (walk
), item
))
663 *prev
= SCM_CDR (walk
);
667 prev
= SCM_CDRLOC (walk
);
674 SCM_PROC(s_delete1_x
, "delete1!", 2, 0, 0, scm_delete1_x
);
676 scm_delete1_x (item
, lst
)
683 for (prev
= &lst
, walk
= lst
;
684 SCM_NIMP (walk
) && SCM_CONSP (walk
);
685 walk
= SCM_CDR (walk
))
687 if (SCM_BOOL_F
!= scm_equal_p (SCM_CAR (walk
), item
))
689 *prev
= SCM_CDR (walk
);
693 prev
= SCM_CDRLOC (walk
);