ac8f8c2623bbcb88d19ddef9d041779f5cb97bb1
1 /* Copyright (C) 1995,1996 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
));
424 sloppy_mem_check (obj
, where
, why
)
429 SCM_ASSERT ((scm_ilength (obj
) >= 0), obj
, where
, why
);
433 SCM_PROC (s_sloppy_memq
, "sloppy-memq", 2, 0, 0, scm_sloppy_memq
);
435 scm_sloppy_memq(x
, lst
)
439 for(; SCM_NIMP(lst
) && SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
448 SCM_PROC (s_sloppy_memv
, "sloppy-memv", 2, 0, 0, scm_sloppy_memv
);
450 scm_sloppy_memv(x
, lst
)
454 for(; SCM_NIMP(lst
) && SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
456 if (SCM_BOOL_F
!= scm_eqv_p (SCM_CAR(lst
), x
))
463 SCM_PROC (s_sloppy_member
, "sloppy-member", 2, 0, 0, scm_sloppy_member
);
465 scm_sloppy_member (x
, lst
)
469 for(; SCM_NIMP(lst
) && SCM_CONSP (lst
); lst
= SCM_CDR(lst
))
471 if (SCM_BOOL_F
!= scm_equal_p (SCM_CAR(lst
), x
))
479 SCM_PROC(s_memq
, "memq", 2, 0, 0, scm_memq
);
486 answer
= scm_sloppy_memq (x
, lst
);
487 sloppy_mem_check (answer
, (char *)SCM_ARG2
, s_memq
);
488 return (answer
== SCM_EOL
) ? SCM_BOOL_F
: answer
;
493 SCM_PROC(s_memv
, "memv", 2, 0, 0, scm_memv
);
500 answer
= scm_sloppy_memv (x
, lst
);
501 sloppy_mem_check (answer
, (char *)SCM_ARG2
, s_memv
);
502 return (answer
== SCM_EOL
) ? SCM_BOOL_F
: answer
;
506 SCM_PROC(s_member
, "member", 2, 0, 0, scm_member
);
513 answer
= scm_sloppy_member (x
, lst
);
514 sloppy_mem_check (answer
, (char *)SCM_ARG2
, s_member
);
515 return (answer
== SCM_EOL
) ? SCM_BOOL_F
: answer
;
520 /* deleting elements from a list (delq, etc.) */
522 SCM_PROC(s_delq_x
, "delq!", 2, 0, 0, scm_delq_x
);
524 scm_delq_x (item
, lst
)
531 for (prev
= &lst
, walk
= lst
;
532 SCM_NIMP (walk
) && SCM_CONSP (walk
);
533 walk
= SCM_CDR (walk
))
535 if (SCM_CAR (walk
) == item
)
536 *prev
= SCM_CDR (walk
);
538 prev
= SCM_CDRLOC (walk
);
545 SCM_PROC(s_delv_x
, "delv!", 2, 0, 0, scm_delv_x
);
547 scm_delv_x (item
, lst
)
554 for (prev
= &lst
, walk
= lst
;
555 SCM_NIMP (walk
) && SCM_CONSP (walk
);
556 walk
= SCM_CDR (walk
))
558 if (SCM_BOOL_F
!= scm_eqv_p (SCM_CAR (walk
), item
))
559 *prev
= SCM_CDR (walk
);
561 prev
= SCM_CDRLOC (walk
);
569 SCM_PROC(s_delete_x
, "delete!", 2, 0, 0, scm_delete_x
);
571 scm_delete_x (item
, lst
)
578 for (prev
= &lst
, walk
= lst
;
579 SCM_NIMP (walk
) && SCM_CONSP (walk
);
580 walk
= SCM_CDR (walk
))
582 if (SCM_BOOL_F
!= scm_equal_p (SCM_CAR (walk
), item
))
583 *prev
= SCM_CDR (walk
);
585 prev
= SCM_CDRLOC (walk
);
595 SCM_PROC (s_delq
, "delq", 2, 0, 0, scm_delq
);
603 copy
= scm_list_copy (lst
);
604 return scm_delq_x (item
, copy
);
607 SCM_PROC (s_delv
, "delv", 2, 0, 0, scm_delv
);
615 copy
= scm_list_copy (lst
);
616 return scm_delv_x (item
, copy
);
619 SCM_PROC (s_delete
, "delete", 2, 0, 0, scm_delete
);
621 scm_delete (item
, lst
)
627 copy
= scm_list_copy (lst
);
628 return scm_delete_x (item
, copy
);