-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-\f
-#include <stdio.h>
-#include "_scm.h"
-
-#ifdef __STDC__
-#include <stdarg.h>
-#define var_start(x, y) va_start(x, y)
-#else
-#include <varargs.h>
-#define var_start(x, y) va_start(x)
-#endif
-
-\f
-
-
-#ifdef __STDC__
-SCM
-scm_listify (SCM elt, ...)
-#else
-SCM
-scm_listify (elt, va_alist)
- SCM elt;
- va_dcl
-
-#endif
-{
- va_list foo;
- SCM answer;
- SCM *pos;
-
- var_start (foo, elt);
- answer = SCM_EOL;
- pos = &answer;
- while (elt != SCM_UNDEFINED)
- {
- *pos = scm_cons (elt, SCM_EOL);
- pos = &SCM_CDR (*pos);
- elt = va_arg (foo, SCM);
- }
- return answer;
-}
-
-
-SCM_PROC(s_list, "list", 0, 0, 1, scm_list);
-#ifdef __STDC__
-SCM
-scm_list(SCM objs)
-#else
-SCM
-scm_list(objs)
- SCM objs;
-#endif
-{
- return objs;
-}
-
-
-
-\f
-
-SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p);
-#ifdef __STDC__
-SCM
-scm_null_p(SCM x)
-#else
-SCM
-scm_null_p(x)
- SCM x;
-#endif
-{
- return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p);
-#ifdef __STDC__
-SCM
-scm_list_p(SCM x)
-#else
-SCM
-scm_list_p(x)
- SCM x;
-#endif
-{
- if (scm_ilength(x)<0)
- return SCM_BOOL_F;
- else
- return SCM_BOOL_T;
-}
-
-
-#ifdef __STDC__
-long
-scm_ilength(SCM sx)
-#else
-long
-scm_ilength(sx)
- SCM sx;
-#endif
-{
- register long i = 0;
- register SCM x = sx;
- do {
- if SCM_IMP(x) return SCM_NULLP(x) ? i : -1;
- if SCM_NCONSP(x) return -1;
- x = SCM_CDR(x);
- i++;
- if SCM_IMP(x) return SCM_NULLP(x) ? i : -1;
- if SCM_NCONSP(x) return -1;
- x = SCM_CDR(x);
- i++;
- sx = SCM_CDR(sx);
- }
- while (x != sx);
- return -1;
-}
-
-SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length);
-#ifdef __STDC__
-SCM
-scm_list_length(SCM x)
-#else
-SCM
-scm_list_length(x)
- SCM x;
-#endif
-{
- int i;
- i = scm_ilength(x);
- SCM_ASSERT(i >= 0, x, SCM_ARG1, s_list_length);
- return SCM_MAKINUM (i);
-}
-
-
-\f
-
-SCM_PROC (s_list_append, "list-append", 0, 0, 1, scm_list_append);
-#ifdef __STDC__
-SCM
-scm_list_append(SCM args)
-#else
-SCM
-scm_list_append(args)
- SCM args;
-#endif
-{
- SCM res = SCM_EOL;
- SCM *lloc = &res, arg;
- if SCM_IMP(args) {
- SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append);
- return res;
- }
- SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append);
- while (1) {
- arg = SCM_CAR(args);
- args = SCM_CDR(args);
- if SCM_IMP(args) {
- *lloc = arg;
- SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append);
- return res;
- }
- SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append);
- for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) {
- SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_list_append);
- *lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
- lloc = &SCM_CDR(*lloc);
- }
- SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_list_append);
- }
-}
-
-
-SCM_PROC (s_list_append_x, "list-append!", 0, 0, 1, scm_list_append_x);
-#ifdef __STDC__
-SCM
-scm_list_append_x(SCM args)
-#else
-SCM
-scm_list_append_x(args)
- SCM args;
-#endif
-{
- SCM arg;
- tail:
- if SCM_NULLP(args) return SCM_EOL;
- arg = SCM_CAR(args);
- SCM_ASSERT(SCM_NULLP(arg) || (SCM_NIMP(arg) && SCM_CONSP(arg)), arg, SCM_ARG1, s_list_append_x);
- args = SCM_CDR(args);
- if SCM_NULLP(args) return arg;
- if SCM_NULLP(arg) goto tail;
- SCM_CDR(scm_last_pair(arg)) = scm_list_append_x(args);
- return arg;
-}
-
-
-\f
-
-
-SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse);
-#ifdef __STDC__
-SCM
-scm_list_reverse(SCM lst)
-#else
-SCM
-scm_list_reverse(lst)
- SCM lst;
-#endif
-{
- SCM res = SCM_EOL;
- SCM p = lst;
- for(;SCM_NIMP(p);p = SCM_CDR(p)) {
- SCM_ASSERT(SCM_CONSP(p), lst, SCM_ARG1, s_list_reverse);
- res = scm_cons(SCM_CAR(p), res);
- }
- SCM_ASSERT(SCM_NULLP(p), lst, SCM_ARG1, s_list_reverse);
- return res;
-}
-
-SCM_PROC (s_list_reverse_x, "list-reverse!", 1, 1, 0, scm_list_reverse_x);
-#ifdef __STDC__
-SCM
-scm_list_reverse_x (SCM lst, SCM newtail)
-#else
-SCM
-scm_list_reverse_x (lst, newtail)
- SCM lst;
- SCM newtail;
-#endif
-{
- SCM old_tail;
- if (newtail == SCM_UNDEFINED)
- newtail = SCM_EOL;
-
- loop:
- if (!(SCM_NIMP (lst) && SCM_CONSP (lst)))
- return lst;
-
- old_tail = SCM_CDR (lst);
- SCM_SETCDR (lst, newtail);
- if (SCM_NULLP (old_tail))
- return lst;
-
- newtail = lst;
- lst = old_tail;
- goto loop;
-}
-
-
-\f
-
-
-SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref);
-#ifdef __STDC__
-SCM
-scm_list_ref(SCM lst, SCM k)
-#else
-SCM
-scm_list_ref(lst, k)
- SCM lst;
- SCM k;
-#endif
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref);
- i = SCM_INUM(k);
- SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_ref);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
-erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_ref);
- return SCM_CAR(lst);
-}
-
-SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x);
-#ifdef __STDC__
-SCM
-scm_list_set_x(SCM lst, SCM k, SCM val)
-#else
-SCM
-scm_list_set_x(lst, k, val)
- SCM lst;
- SCM k;
- SCM val;
-#endif
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x);
- i = SCM_INUM(k);
- SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_set_x);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
-erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x);
- SCM_CAR (lst) = val;
- return val;
-}
-
-
-
-SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x);
-#ifdef __STDC__
-SCM
-scm_list_cdr_set_x(SCM lst, SCM k, SCM val)
-#else
-SCM
-scm_list_cdr_set_x(lst, k, val)
- SCM lst;
- SCM k;
- SCM val;
-#endif
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x);
- i = SCM_INUM(k);
- SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_cdr_set_x);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
-erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_cdr_set_x);
- SCM_SETCDR (lst, val);
- return val;
-}
-
-
-\f
-
-
-
-SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
-#ifdef __STDC__
-SCM
-scm_last_pair(SCM sx)
-#else
-SCM
-scm_last_pair(sx)
- SCM sx;
-#endif
-{
- register SCM res = sx;
- register SCM x;
-
- if (SCM_NULLP (sx))
- return SCM_EOL;
-
- SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair);
- while (!0) {
- x = SCM_CDR(res);
- if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
- res = x;
- x = SCM_CDR(res);
- if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
- res = x;
- sx = SCM_CDR(sx);
- SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair);
- }
-}
-
-SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
-SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail);
-#ifdef __STDC__
-SCM
-scm_list_tail(SCM lst, SCM k)
-#else
-SCM
-scm_list_tail(lst, k)
- SCM lst;
- SCM k;
-#endif
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail);
- i = SCM_INUM(k);
- while (i-- > 0) {
- SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail);
- lst = SCM_CDR(lst);
- }
- return lst;
-}
-
-
-SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head);
-#ifdef __STDC__
-SCM
-scm_list_head(SCM lst, SCM k)
-#else
-SCM
-scm_list_head(lst, k)
- SCM lst;
- SCM k;
-#endif
-{
- SCM answer;
- SCM * pos;
- register long i;
-
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_head);
- answer = SCM_EOL;
- pos = &answer;
- i = SCM_INUM(k);
- while (i-- > 0)
- {
- SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head);
- *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
- pos = &SCM_CDR (*pos);
- lst = SCM_CDR(lst);
- }
- return answer;
-}
-
-
-\f
-
-#ifdef __STDC__
-static void
-sloppy_mem_check (SCM obj, char * where, char * why)
-#else
-static void
-sloppy_mem_check (obj, where, why)
- SCM obj;
- char * where;
- char * why;
-#endif
-{
- SCM_ASSERT ((scm_ilength (obj) >= 0), obj, where, why);
-}
-
-
-SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq);
-#ifdef __STDC__
-SCM
-scm_sloppy_memq(SCM x, SCM lst)
-#else
-SCM
-scm_sloppy_memq(x, lst)
- SCM x;
- SCM lst;
-#endif
-{
- for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (SCM_CAR(lst)==x)
- return lst;
- }
- return lst;
-}
-
-
-SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv);
-#ifdef __STDC__
-SCM
-scm_sloppy_memv(SCM x, SCM lst)
-#else
-SCM
-scm_sloppy_memv(x, lst)
- SCM x;
- SCM lst;
-#endif
-{
- for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR(lst), x))
- return lst;
- }
- return lst;
-}
-
-
-SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member);
-#ifdef __STDC__
-SCM
-scm_sloppy_member (SCM x, SCM lst)
-#else
-SCM
-scm_sloppy_member (x, lst)
- SCM x;
- SCM lst;
-#endif
-{
- for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR(lst), x))
- return lst;
- }
- return lst;
-}
-
-
-
-SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq);
-#ifdef __STDC__
-SCM
-scm_memq(SCM x, SCM lst)
-#else
-SCM
-scm_memq(x, lst)
- SCM x;
- SCM lst;
-#endif
-{
- SCM answer;
- answer = scm_sloppy_memq (x, lst);
- sloppy_mem_check (answer, (char *)SCM_ARG2, s_memq);
- return answer;
-}
-
-
-
-SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv);
-#ifdef __STDC__
-SCM
-scm_memv(SCM x, SCM lst)
-#else
-SCM
-scm_memv(x, lst)
- SCM x;
- SCM lst;
-#endif
-{
- SCM answer;
- answer = scm_sloppy_memv (x, lst);
- sloppy_mem_check (answer, (char *)SCM_ARG2, s_memv);
- return answer;
-}
-
-
-SCM_PROC(s_member, "member", 2, 0, 0, scm_member);
-#ifdef __STDC__
-SCM
-scm_member(SCM x, SCM lst)
-#else
-SCM
-scm_member(x, lst)
- SCM x;
- SCM lst;
-#endif
-{
- SCM answer;
- answer = scm_sloppy_member (x, lst);
- sloppy_mem_check (answer, (char *)SCM_ARG2, s_member);
- return answer;
-}
-
-
-\f
-
-SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x);
-#ifdef __STDC__
-SCM
-scm_delq_x (SCM item, SCM lst)
-#else
-SCM
-scm_delq_x (item, lst)
- SCM item;
- SCM lst;
-#endif
-{
- SCM start;
-
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
-
- if (SCM_CAR (lst) == item)
- return SCM_CDR (lst);
-
- start = lst;
-
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
- {
- if (SCM_CAR (SCM_CDR (lst)) == item)
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
- }
- return start;
-}
-
-
-SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x);
-#ifdef __STDC__
-SCM
-scm_delv_x (SCM item, SCM lst)
-#else
-SCM
-scm_delv_x (item, lst)
- SCM item;
- SCM lst;
-#endif
-{
- SCM start;
-
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
-
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (lst), item))
- return SCM_CDR (lst);
-
- start = lst;
-
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
- {
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (SCM_CDR (lst)), item))
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
- }
- return start;
-}
-
-
-
-SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x);
-#ifdef __STDC__
-SCM
-scm_delete_x (SCM item, SCM lst)
-#else
-SCM
-scm_delete_x (item, lst)
- SCM item;
- SCM lst;
-#endif
-{
- SCM start;
-
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
-
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR (lst), item))
- return SCM_CDR (lst);
-
- start = lst;
-
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
- {
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR (SCM_CDR (lst)), item))
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
- }
- return start;
-}
-
-
-\f
-
-SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy);
-#ifdef __STDC__
-SCM
-scm_list_copy (SCM lst)
-#else
-SCM
-scm_list_copy (lst)
- SCM lst;
-#endif
-{
- SCM newlst;
- SCM * fill_here;
- SCM from_here;
-
- newlst = SCM_EOL;
- fill_here = &newlst;
- from_here = lst;
-
- while (SCM_NIMP (from_here) && SCM_CONSP (from_here))
- {
- SCM c;
- c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
- *fill_here = c;
- fill_here = &SCM_CDR (c);
- from_here = SCM_CDR (from_here);
- }
- return newlst;
-}
-\f
-
-
-SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq);
-#ifdef __STDC__
-SCM
-scm_delq (SCM item, SCM lst)
-#else
-SCM
-scm_delq (item, lst)
- SCM item;
- SCM lst;
-#endif
-{
- SCM copy;
-
- copy = scm_list_copy (lst);
- return scm_delq_x (item, copy);
-}
-
-SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv);
-#ifdef __STDC__
-SCM
-scm_delv (SCM item, SCM lst)
-#else
-SCM
-scm_delv (item, lst)
- SCM item;
- SCM lst;
-#endif
-{
- SCM copy;
-
- copy = scm_list_copy (lst);
- return scm_delv_x (item, copy);
-}
-
-SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete);
-#ifdef __STDC__
-SCM
-scm_delete (SCM item, SCM lst)
-#else
-SCM
-scm_delete (item, lst)
- SCM item;
- SCM lst;
-#endif
-{
- SCM copy;
-
- copy = scm_list_copy (lst);
- return scm_delete_x (item, copy);
-}
-
-
-\f
-
-#ifdef __STDC__
-void
-scm_init_list (void)
-#else
-void
-scm_init_list ()
-#endif
-{
-#include "list.x"
-}
-
+/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+
+\f
+#include <stdio.h>
+#include "libguile/_scm.h"
+#include "libguile/eq.h"
+
+#include "libguile/validate.h"
+#include "libguile/list.h"
+
+#ifdef __STDC__
+#include <stdarg.h>
+#define var_start(x, y) va_start(x, y)
+#else
+#include <varargs.h>
+#define var_start(x, y) va_start(x)
+#endif
+
+\f
+/* creating lists */
+
+SCM
+scm_listify (SCM elt, ...)
+{
+ va_list foo;
+ SCM answer = SCM_EOL;
+ SCM *pos = &answer;
+
+ var_start (foo, elt);
+ while (! SCM_UNBNDP (elt))
+ {
+ *pos = scm_cons (elt, SCM_EOL);
+ pos = SCM_CDRLOC (*pos);
+ elt = va_arg (foo, SCM);
+ }
+ return answer;
+}
+
+
+SCM_DEFINE (scm_list, "list", 0, 0, 1,
+ (SCM objs),
+ "Return a list containing OBJS, the arguments to `list'.")
+#define FUNC_NAME s_scm_list
+{
+ return objs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_star, "list*", 1, 0, 1,
+ (SCM arg, SCM rest),
+ "Return an improper list of the arguments.")
+#define FUNC_NAME s_scm_list_star
+{
+ if (SCM_NNULLP (rest))
+ {
+ SCM prev = arg = scm_cons (arg, rest);
+ while (SCM_NNULLP (SCM_CDR (rest)))
+ {
+ prev = rest;
+ rest = SCM_CDR (rest);
+ }
+ SCM_SETCDR (prev, SCM_CAR (rest));
+ }
+ return arg;
+}
+#undef FUNC_NAME
+
+
+\f
+/* general questions about lists --- null?, list?, length, etc. */
+
+SCM_DEFINE (scm_null_p, "null?", 1, 0, 0,
+ (SCM x),
+ "Return #t iff X is the empty list, else #f.")
+#define FUNC_NAME s_scm_null_p
+{
+ return SCM_BOOL (SCM_NULLP (x));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
+ (SCM x),
+ "Return #t iff X is a proper list, else #f.")
+#define FUNC_NAME s_scm_list_p
+{
+ return SCM_BOOL (scm_ilength (x) >= 0);
+}
+#undef FUNC_NAME
+
+
+/* Return the length of SX, or -1 if it's not a proper list.
+ This uses the "tortoise and hare" algorithm to detect "infinitely
+ long" lists (i.e. lists with cycles in their cdrs), and returns -1
+ if it does find one. */
+long
+scm_ilength(SCM sx)
+{
+ long i = 0;
+ SCM tortoise = sx;
+ SCM hare = sx;
+
+ do {
+ if (SCM_NULLP(hare)) return i;
+ if (SCM_NCONSP(hare)) return -1;
+ hare = SCM_CDR(hare);
+ i++;
+ if (SCM_NULLP(hare)) return i;
+ if (SCM_NCONSP(hare)) return -1;
+ hare = SCM_CDR(hare);
+ i++;
+ /* For every two steps the hare takes, the tortoise takes one. */
+ tortoise = SCM_CDR(tortoise);
+ }
+ while (! SCM_EQ_P (hare, tortoise));
+
+ /* If the tortoise ever catches the hare, then the list must contain
+ a cycle. */
+ return -1;
+}
+
+
+SCM_DEFINE (scm_length, "length", 1, 0, 0,
+ (SCM lst),
+ "Return the number of elements in list LST.")
+#define FUNC_NAME s_scm_length
+{
+ int i;
+ SCM_VALIDATE_LIST_COPYLEN (1,lst,i);
+ return SCM_MAKINUM (i);
+}
+#undef FUNC_NAME
+
+
+\f
+/* appending lists */
+
+SCM_DEFINE (scm_append, "append", 0, 0, 1,
+ (SCM args),
+ "Returns a list consisting of the elements of the first LIST\n"
+ "followed by the elements of the other LISTs.\n"
+ "\n"
+ " (append '(x) '(y)) => (x y)\n"
+ " (append '(a) '(b c d)) => (a b c d)\n"
+ " (append '(a (b)) '((c))) => (a (b) (c))\n"
+ "\n"
+ "The resulting list is always newly allocated, except that it shares\n"
+ "structure with the last LIST argument. The last argument may\n"
+ "actually be any object; an improper list results if the last\n"
+ "argument is not a proper list.\n"
+
+ " (append '(a b) '(c . d)) => (a b c . d)\n"
+ " (append '() 'a) => a\n")
+#define FUNC_NAME s_scm_append
+{
+ SCM res = SCM_EOL;
+ SCM *lloc = &res, arg;
+ if (SCM_IMP(args)) {
+ SCM_VALIDATE_NULL (SCM_ARGn, args);
+ return res;
+ }
+ SCM_VALIDATE_CONS (SCM_ARGn, args);
+ while (1) {
+ arg = SCM_CAR(args);
+ args = SCM_CDR(args);
+ if (SCM_IMP(args)) {
+ *lloc = arg;
+ SCM_VALIDATE_NULL (SCM_ARGn, args);
+ return res;
+ }
+ SCM_VALIDATE_CONS (SCM_ARGn, args);
+ for (; SCM_CONSP(arg); arg = SCM_CDR(arg)) {
+ *lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
+ lloc = SCM_CDRLOC(*lloc);
+ }
+ SCM_VALIDATE_NULL (SCM_ARGn, arg);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
+ (SCM args),
+ "A destructive version of @code{append} (@pxref{Pairs and Lists,,,r4rs,\n"
+ "The Revised^4 Report on Scheme}). The cdr field of each list's final\n"
+ "pair is changed to point to the head of the next list, so no consing is\n"
+ "performed. Return a pointer to the mutated list.")
+#define FUNC_NAME s_scm_append_x
+{
+ SCM arg;
+ tail:
+ if (SCM_NULLP(args)) return SCM_EOL;
+ arg = SCM_CAR(args);
+ args = SCM_CDR(args);
+ if (SCM_NULLP(args)) return arg;
+ if (SCM_NULLP(arg)) goto tail;
+ SCM_VALIDATE_CONS (SCM_ARG1,arg);
+ SCM_SETCDR (scm_last_pair (arg), scm_append_x (args));
+ return arg;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0,
+ (SCM lst),
+ "Return a pointer to the last pair in @var{lst}, signalling an error if\n"
+ "@var{lst} is circular.")
+#define FUNC_NAME s_scm_last_pair
+{
+ SCM tortoise = lst;
+ SCM hare = lst;
+
+ if (SCM_NULLP (lst))
+ return SCM_EOL;
+
+ SCM_VALIDATE_CONS (SCM_ARG1, lst);
+ do {
+ SCM ahead = SCM_CDR(hare);
+ if (SCM_NCONSP(ahead)) return hare;
+ hare = ahead;
+ ahead = SCM_CDR(hare);
+ if (SCM_NCONSP(ahead)) return hare;
+ hare = ahead;
+ tortoise = SCM_CDR(tortoise);
+ }
+ while (! SCM_EQ_P (hare, tortoise));
+ SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst));
+}
+#undef FUNC_NAME
+
+\f
+/* reversing lists */
+
+SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
+ (SCM lst),
+ "Return a new list that contains the elements of LST but in reverse order.")
+#define FUNC_NAME s_scm_reverse
+{
+ SCM result = SCM_EOL;
+ SCM tortoise = lst;
+ SCM hare = lst;
+
+ do {
+ if (SCM_NULLP(hare)) return result;
+ SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME);
+ result = scm_cons (SCM_CAR (hare), result);
+ hare = SCM_CDR (hare);
+ if (SCM_NULLP(hare)) return result;
+ SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME);
+ result = scm_cons (SCM_CAR (hare), result);
+ hare = SCM_CDR (hare);
+ tortoise = SCM_CDR (tortoise);
+ }
+ while (! SCM_EQ_P (hare, tortoise));
+ SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
+ (SCM lst, SCM new_tail),
+ "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r4rs,\n"
+ "The Revised^4 Report on Scheme}). The cdr of each cell in @var{lst} is\n"
+ "modified to point to the previous list element. Return a pointer to the\n"
+ "head of the reversed list.\n\n"
+ "Caveat: because the list is modified in place, the tail of the original\n"
+ "list now becomes its head, and the head of the original list now becomes\n"
+ "the tail. Therefore, the @var{lst} symbol to which the head of the\n"
+ "original list was bound now points to the tail. To ensure that the head\n"
+ "of the modified list is not lost, it is wise to save the return value of\n"
+ "@code{reverse!}")
+#define FUNC_NAME s_scm_reverse_x
+{
+ SCM_ASSERT (scm_ilength (lst) >= 0, lst, SCM_ARG1, FUNC_NAME);
+ if (SCM_UNBNDP (new_tail))
+ new_tail = SCM_EOL;
+ else
+ SCM_ASSERT (scm_ilength (new_tail) >= 0, new_tail, SCM_ARG2, FUNC_NAME);
+
+ while (SCM_NNULLP (lst))
+ {
+ SCM old_tail = SCM_CDR (lst);
+ SCM_SETCDR (lst, new_tail);
+ new_tail = lst;
+ lst = old_tail;
+ }
+ return new_tail;
+}
+#undef FUNC_NAME
+
+
+\f
+/* indexing lists by element number */
+
+SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
+ (SCM lst, SCM k),
+ "Return the Kth element from list LST.")
+#define FUNC_NAME s_scm_list_ref
+{
+ register long i;
+ SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
+ while (i-- > 0) {
+ SCM_ASRTGO(SCM_CONSP(lst), erout);
+ lst = SCM_CDR(lst);
+ }
+ erout:
+ SCM_ASSERT(SCM_CONSP(lst),
+ SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
+ return SCM_CAR(lst);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
+ (SCM lst, SCM k, SCM val),
+ "Set the @var{k}th element of @var{lst} to @var{val}.")
+#define FUNC_NAME s_scm_list_set_x
+{
+ register long i;
+ SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
+ while (i-- > 0) {
+ SCM_ASRTGO(SCM_CONSP(lst), erout);
+ lst = SCM_CDR(lst);
+ }
+ erout:
+ SCM_ASSERT(SCM_CONSP(lst),
+ SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
+ SCM_SETCAR (lst, val);
+ return val;
+}
+#undef FUNC_NAME
+
+
+SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
+
+SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
+ (SCM lst, SCM k),
+ "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
+ "The first element of the list is considered to be element 0.\n\n"
+ "@code{list-cdr-ref} and @code{list-tail} are identical. It may help to\n"
+ "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
+ "or returning the results of cdring @var{k} times down @var{lst}.")
+#define FUNC_NAME s_scm_list_tail
+{
+ register long i;
+ SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
+ while (i-- > 0) {
+ SCM_VALIDATE_CONS (1,lst);
+ lst = SCM_CDR(lst);
+ }
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
+ (SCM lst, SCM k, SCM val),
+ "Set the @var{k}th cdr of @var{lst} to @var{val}.")
+#define FUNC_NAME s_scm_list_cdr_set_x
+{
+ register long i;
+ SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
+ while (i-- > 0) {
+ SCM_ASRTGO(SCM_CONSP(lst), erout);
+ lst = SCM_CDR(lst);
+ }
+erout:
+ SCM_ASSERT(SCM_CONSP(lst),
+ SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, FUNC_NAME);
+ SCM_SETCDR (lst, val);
+ return val;
+}
+#undef FUNC_NAME
+
+
+\f
+/* copying lists, perhaps partially */
+
+SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
+ (SCM lst, SCM k),
+ "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
+ "return it.")
+#define FUNC_NAME s_scm_list_head
+{
+ SCM answer;
+ SCM * pos;
+ register long i;
+
+ SCM_VALIDATE_INUM_MIN_COPY (2,k,0,i);
+ answer = SCM_EOL;
+ pos = &answer;
+ while (i-- > 0)
+ {
+ SCM_VALIDATE_CONS (1,lst);
+ *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
+ pos = SCM_CDRLOC (*pos);
+ lst = SCM_CDR(lst);
+ }
+ return answer;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
+ (SCM lst),
+ "Return a (newly-created) copy of @var{lst}.")
+#define FUNC_NAME s_scm_list_copy
+{
+ SCM newlst;
+ SCM * fill_here;
+ SCM from_here;
+
+ newlst = SCM_EOL;
+ fill_here = &newlst;
+ from_here = lst;
+
+ while (SCM_CONSP (from_here))
+ {
+ SCM c;
+ c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
+ *fill_here = c;
+ fill_here = SCM_CDRLOC (c);
+ from_here = SCM_CDR (from_here);
+ }
+ return newlst;
+}
+#undef FUNC_NAME
+
+\f
+/* membership tests (memq, memv, etc.) */
+
+SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
+ (SCM x, SCM lst),
+ "This procedure behaves like @code{memq}, but does no type or error checking.\n"
+ "Its use is recommended only in writing Guile internals,\n"
+ "not for high-level Scheme programs.")
+#define FUNC_NAME s_scm_sloppy_memq
+{
+ for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
+ {
+ if (SCM_EQ_P (SCM_CAR (lst), x))
+ return lst;
+ }
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
+ (SCM x, SCM lst),
+ "This procedure behaves like @code{memv}, but does no type or error checking.\n"
+ "Its use is recommended only in writing Guile internals,\n"
+ "not for high-level Scheme programs.")
+#define FUNC_NAME s_scm_sloppy_memv
+{
+ for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
+ {
+ if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst), x)))
+ return lst;
+ }
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
+ (SCM x, SCM lst),
+ "This procedure behaves like @code{member}, but does no type or error checking.\n"
+ "Its use is recommended only in writing Guile internals,\n"
+ "not for high-level Scheme programs.")
+#define FUNC_NAME s_scm_sloppy_member
+{
+ for(; SCM_CONSP (lst); lst = SCM_CDR(lst))
+ {
+ if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst), x)))
+ return lst;
+ }
+ return lst;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
+ (SCM x, SCM lst),
+ "Return the first sublist of LST whose car is `eq?' to X\n"
+ "where the sublists of LST are the non-empty lists returned\n"
+ "by `(list-tail LST K)' for K less than the length of LST. If\n"
+ "X does not occur in LST, then `#f' (not the empty list) is\n"
+ "returned.")
+#define FUNC_NAME s_scm_memq
+{
+ SCM answer;
+ SCM_VALIDATE_LIST (2,lst);
+ answer = scm_sloppy_memq (x, lst);
+ return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
+ (SCM x, SCM lst),
+ "Return the first sublist of LST whose car is `eqv?' to X\n"
+ "where the sublists of LST are the non-empty lists returned\n"
+ "by `(list-tail LST K)' for K less than the length of LST. If\n"
+ "X does not occur in LST, then `#f' (not the empty list) is\n"
+ "returned.")
+#define FUNC_NAME s_scm_memv
+{
+ SCM answer;
+ SCM_VALIDATE_LIST (2,lst);
+ answer = scm_sloppy_memv (x, lst);
+ return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_member, "member", 2, 0, 0,
+ (SCM x, SCM lst),
+ "Return the first sublist of LST whose car is `equal?' to X\n"
+ "where the sublists of LST are the non-empty lists returned\n"
+ "by `(list-tail LST K)' for K less than the length of LST. If\n"
+ "X does not occur in LST, then `#f' (not the empty list) is\n"
+ "returned.")
+#define FUNC_NAME s_scm_member
+{
+ SCM answer;
+ SCM_VALIDATE_LIST (2,lst);
+ answer = scm_sloppy_member (x, lst);
+ return (SCM_NULLP (answer)) ? SCM_BOOL_F : answer;
+}
+#undef FUNC_NAME
+
+
+\f
+/* deleting elements from a list (delq, etc.) */
+
+SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "@deffnx primitive delv! item lst\n"
+ "@deffnx primitive delete! item lst\n"
+ "These procedures are destructive versions of @code{delq}, @code{delv}\n"
+ "and @code{delete}: they modify the pointers in the existing @var{lst}\n"
+ "rather than creating a new list. Caveat evaluator: Like other\n"
+ "destructive list functions, these functions cannot modify the binding of\n"
+ "@var{lst}, and so cannot be used to delete the first element of\n"
+ "@var{lst} destructively.")
+#define FUNC_NAME s_scm_delq_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (SCM_EQ_P (SCM_CAR (walk), item))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Destructively remove all elements from LST that are `eqv?' to ITEM.")
+#define FUNC_NAME s_scm_delv_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk), item)))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Destructively remove all elements from LST that are `equal?' to ITEM.")
+#define FUNC_NAME s_scm_delete_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk), item)))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Return a newly-created copy of @var{lst} with elements `eq?' to @var{item} removed.\n"
+ "This procedure mirrors @code{memq}:\n"
+ "@code{delq} compares elements of @var{lst} against @var{item} with\n"
+ "@code{eq?}.")
+#define FUNC_NAME s_scm_delq
+{
+ SCM copy = scm_list_copy (lst);
+ return scm_delq_x (item, copy);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Return a newly-created copy of @var{lst} with elements `eqv?' to @var{item} removed.\n"
+ "This procedure mirrors @code{memv}:\n"
+ "@code{delv} compares elements of @var{lst} against @var{item} with\n"
+ "@code{eqv?}.")
+#define FUNC_NAME s_scm_delv
+{
+ SCM copy = scm_list_copy (lst);
+ return scm_delv_x (item, copy);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Return a newly-created copy of @var{lst} with elements `equal?' to @var{item} removed.\n"
+ "This procedure mirrors @code{member}:\n"
+ "@code{delete} compares elements of @var{lst} against @var{item} with\n"
+ "@code{equal?}.")
+#define FUNC_NAME s_scm_delete
+{
+ SCM copy = scm_list_copy (lst);
+ return scm_delete_x (item, copy);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Like `delq!', but only deletes the first occurrence of ITEM from LST.\n"
+ "Tests for equality using `eq?'. See also `delv1!' and `delete1!'.")
+#define FUNC_NAME s_scm_delq1_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (SCM_EQ_P (SCM_CAR (walk), item))
+ {
+ *prev = SCM_CDR (walk);
+ break;
+ }
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Like `delv!', but only deletes the first occurrence of ITEM from LST.\n"
+ "Tests for equality using `eqv?'. See also `delq1!' and `delete1!'.")
+#define FUNC_NAME s_scm_delv1_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (walk), item)))
+ {
+ *prev = SCM_CDR (walk);
+ break;
+ }
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Like `delete!', but only deletes the first occurrence of ITEM from LST.\n"
+ "Tests for equality using `equal?'. See also `delq1!' and `delv1!'.")
+#define FUNC_NAME s_scm_delete1_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ SCM_CONSP (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (! SCM_FALSEP (scm_equal_p (SCM_CAR (walk), item)))
+ {
+ *prev = SCM_CDR (walk);
+ break;
+ }
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+\f
+void
+scm_init_list ()
+{
+#include "libguile/list.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff