summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/Makefile.am4
-rw-r--r--libguile/init.c2
-rw-r--r--libguile/srfi-1.c885
-rw-r--r--libguile/srfi-1.h47
4 files changed, 0 insertions, 938 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ce97abad7..0890acc18 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -210,7 +210,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
smob.c \
sort.c \
srcprop.c \
- srfi-1.c \
srfi-4.c \
srfi-13.c \
srfi-14.c \
@@ -324,7 +323,6 @@ DOT_X_FILES = \
smob.x \
sort.x \
srcprop.x \
- srfi-1.x \
srfi-4.x \
srfi-13.x \
srfi-14.x \
@@ -426,7 +424,6 @@ DOT_DOC_FILES = \
smob.doc \
sort.doc \
srcprop.doc \
- srfi-1.doc \
srfi-4.doc \
srfi-13.doc \
srfi-14.doc \
@@ -691,7 +688,6 @@ modinclude_HEADERS = \
socket.h \
sort.h \
srcprop.h \
- srfi-1.h \
srfi-4.h \
srfi-13.h \
srfi-14.h \
diff --git a/libguile/init.c b/libguile/init.c
index 4022728f9..4a3903a2c 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -128,7 +128,6 @@
#include "socket.h"
#include "sort.h"
#include "srcprop.h"
-#include "srfi-1.h"
#include "srfi-13.h"
#include "srfi-14.h"
#include "srfi-4.h"
@@ -377,7 +376,6 @@ scm_i_init_guile (void *base)
scm_register_fdes_finalizers ();
scm_register_foreign ();
scm_register_foreign_object ();
- scm_register_srfi_1 ();
scm_register_srfi_60 ();
scm_register_poll ();
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
deleted file mode 100644
index b18ba41c7..000000000
--- a/libguile/srfi-1.c
+++ /dev/null
@@ -1,885 +0,0 @@
-/* srfi-1.c --- SRFI-1 procedures for Guile
-
- Copyright 1995-1997,2000-2003,2005-2006,2008-2011,2013-2014,2018,2020
- Free Software Foundation, Inc.
-
- This file is part of Guile.
-
- Guile is free software: you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- Guile 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 Lesser General Public
- License for more details.
-
- You should have received a copy of the GNU Lesser General Public
- License along with Guile. If not, see
- <https://www.gnu.org/licenses/>. */
-
-
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <stdarg.h>
-
-#include "boolean.h"
-#include "eq.h"
-#include "eval.h"
-#include "extensions.h"
-#include "gsubr.h"
-#include "list.h"
-#include "pairs.h"
-#include "procs.h"
-#include "values.h"
-#include "vectors.h"
-#include "version.h"
-
-#include "srfi-1.h"
-
-
-/* The intent of this file was to gradually replace those Scheme
- * procedures in srfi-1.scm that extend core primitive procedures,
- * so that using srfi-1 wouldn't have performance penalties.
- *
- * However, we now prefer to write these procedures in Scheme, let the compiler
- * optimize them, and have the VM execute them efficiently.
- */
-
-
-static SCM
-equal_trampoline (SCM proc, SCM arg1, SCM arg2)
-{
- return scm_equal_p (arg1, arg2);
-}
-
-/* list_copy_part() copies the first COUNT cells of LST, puts the result at
- *dst, and returns the SCM_CDRLOC of the last cell in that new list.
-
- This function is designed to be careful about LST possibly having changed
- in between the caller deciding what to copy, and the copy actually being
- done here. The COUNT ensures we terminate if LST has become circular,
- SCM_VALIDATE_CONS guards against a cdr in the list changed to some
- non-pair object. */
-
-#include <stdio.h>
-static SCM *
-list_copy_part (SCM lst, int count, SCM *dst)
-#define FUNC_NAME "list_copy_part"
-{
- SCM c;
- for ( ; count > 0; count--)
- {
- SCM_VALIDATE_CONS (SCM_ARGn, lst);
- c = scm_cons (SCM_CAR (lst), SCM_EOL);
- *dst = c;
- dst = SCM_CDRLOC (c);
- lst = SCM_CDR (lst);
- }
- return dst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0,
- (SCM revhead, SCM tail),
- "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
- "result. This is equivalent to @code{(append (reverse\n"
- "@var{rev-head}) @var{tail})}, but its implementation is more\n"
- "efficient.\n"
- "\n"
- "@example\n"
- "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi1_append_reverse
-{
- while (scm_is_pair (revhead))
- {
- /* copy first element of revhead onto front of tail */
- tail = scm_cons (SCM_CAR (revhead), tail);
- revhead = SCM_CDR (revhead);
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
- "list");
- return tail;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
- (SCM revhead, SCM tail),
- "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
- "result. This is equivalent to @code{(append! (reverse!\n"
- "@var{rev-head}) @var{tail})}, but its implementation is more\n"
- "efficient.\n"
- "\n"
- "@example\n"
- "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
- "@end example\n"
- "\n"
- "@var{rev-head} may be modified in order to produce the result.")
-#define FUNC_NAME s_scm_srfi1_append_reverse_x
-{
- SCM newtail;
-
- while (scm_is_mutable_pair (revhead))
- {
- /* take the first cons cell from revhead */
- newtail = revhead;
- revhead = SCM_CDR (revhead);
-
- /* make it the new start of tail, appending the previous */
- SCM_SETCDR (newtail, tail);
- tail = newtail;
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
- "list");
- return tail;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
- (SCM lstlst),
- "Construct a list by appending all lists in @var{lstlst}.\n"
- "\n"
- "@code{concatenate} is the same as @code{(apply append\n"
- "@var{lstlst})}. It exists because some Scheme implementations\n"
- "have a limit on the number of arguments a function takes, which\n"
- "the @code{apply} might exceed. In Guile there is no such\n"
- "limit.")
-#define FUNC_NAME s_scm_srfi1_concatenate
-{
- SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
- return scm_append (lstlst);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_concatenate_x, "concatenate!", 1, 0, 0,
- (SCM lstlst),
- "Construct a list by appending all lists in @var{lstlst}. Those\n"
- "lists may be modified to produce the result.\n"
- "\n"
- "@code{concatenate!} is the same as @code{(apply append!\n"
- "@var{lstlst})}. It exists because some Scheme implementations\n"
- "have a limit on the number of arguments a function takes, which\n"
- "the @code{apply} might exceed. In Guile there is no such\n"
- "limit.")
-#define FUNC_NAME s_scm_srfi1_concatenate_x
-{
- SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
- return scm_append_x (lstlst);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
- (SCM pred, SCM list1, SCM rest),
- "Return a count of the number of times @var{pred} returns true\n"
- "when called on elements from the given lists.\n"
- "\n"
- "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
- "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
- "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
- "with the first element of each list, the second with the second\n"
- "element from each, and so on.\n"
- "\n"
- "Counting stops when the end of the shortest list is reached.\n"
- "At least one list must be non-circular.")
-#define FUNC_NAME s_scm_srfi1_count
-{
- long count;
- SCM lst;
- int argnum;
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- count = 0;
-
- if (scm_is_null (rest))
- {
- /* one list */
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
- for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
- count += scm_is_true (scm_call_1 (pred, SCM_CAR (list1)));
-
- /* check below that list1 is a proper list, and done */
- end_list1:
- lst = list1;
- argnum = 2;
- }
- else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
- {
- /* two lists */
- SCM list2;
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
- list2 = SCM_CAR (rest);
- for (;;)
- {
- if (! scm_is_pair (list1))
- goto end_list1;
- if (! scm_is_pair (list2))
- {
- lst = list2;
- argnum = 3;
- break;
- }
- count += scm_is_true (scm_call_2
- (pred, SCM_CAR (list1), SCM_CAR (list2)));
- list1 = SCM_CDR (list1);
- list2 = SCM_CDR (list2);
- }
- }
- else
- {
- /* three or more lists */
- SCM vec, args, a;
- size_t len, i;
-
- /* vec is the list arguments */
- vec = scm_vector (scm_cons (list1, rest));
- len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
- /* args is the argument list to pass to pred, same length as vec,
- re-used for each call */
- args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
-
- for (;;)
- {
- /* first elem of each list in vec into args, and step those
- vec entries onto their next element */
- for (i = 0, a = args, argnum = 2;
- i < len;
- i++, a = SCM_CDR (a), argnum++)
- {
- lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
- if (! scm_is_pair (lst))
- goto check_lst_and_done;
- SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
- SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
- }
-
- count += scm_is_true (scm_apply_0 (pred, args));
- }
- }
-
- check_lst_and_done:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
- return scm_from_long (count);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
- (SCM x, SCM lst, SCM pred),
- "Return a list containing the elements of @var{lst} but with\n"
- "those equal to @var{x} deleted. The returned elements will be\n"
- "in the same order as they were in @var{lst}.\n"
- "\n"
- "Equality is determined by @var{pred}, or @code{equal?} if not\n"
- "given. An equality call is made just once for each element,\n"
- "but the order in which the calls are made on the elements is\n"
- "unspecified.\n"
- "\n"
- "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
- "given @var{x} is first. This means for instance elements\n"
- "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
- "\n"
- "@var{lst} is not modified, but the returned list might share a\n"
- "common tail with @var{lst}.")
-#define FUNC_NAME s_scm_srfi1_delete
-{
- SCM ret, *p, keeplst;
- int count;
-
- if (SCM_UNBNDP (pred))
- return scm_delete (x, lst);
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
-
- /* ret is the return list being constructed. p is where to append to it,
- initially &ret then SCM_CDRLOC of the last pair. lst progresses as
- elements are considered.
-
- Elements to be retained are not immediately copied, instead keeplst is
- the last pair in lst which is to be retained but not yet copied, count
- is how many from there are wanted. When there's no more deletions, *p
- can be set to keeplst to share the remainder of the original lst. (The
- entire original lst if there's no deletions at all.) */
-
- keeplst = lst;
- count = 0;
- p = &ret;
-
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (lst))))
- {
- /* delete this element, so copy those at keeplst */
- p = list_copy_part (keeplst, count, p);
- keeplst = SCM_CDR (lst);
- count = 0;
- }
- else
- {
- /* keep this element */
- count++;
- }
- }
-
- /* final retained elements */
- *p = keeplst;
-
- /* demand that lst was a proper list */
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0,
- (SCM x, SCM lst, SCM pred),
- "Return a list containing the elements of @var{lst} but with\n"
- "those equal to @var{x} deleted. The returned elements will be\n"
- "in the same order as they were in @var{lst}.\n"
- "\n"
- "Equality is determined by @var{pred}, or @code{equal?} if not\n"
- "given. An equality call is made just once for each element,\n"
- "but the order in which the calls are made on the elements is\n"
- "unspecified.\n"
- "\n"
- "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
- "given @var{x} is first. This means for instance elements\n"
- "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
- "\n"
- "@var{lst} may be modified to construct the returned list.")
-#define FUNC_NAME s_scm_srfi1_delete_x
-{
- SCM walk;
- SCM *prev;
-
- if (SCM_UNBNDP (pred))
- return scm_delete_x (x, lst);
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
-
- for (prev = &lst, walk = lst;
- scm_is_pair (walk);
- walk = SCM_CDR (walk))
- {
- if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (walk))))
- *prev = SCM_CDR (walk);
- else
- prev = SCM_CDRLOC (walk);
- }
-
- /* demand the input was a proper list */
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list");
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
- (SCM lst, SCM pred),
- "Return a list containing the elements of @var{lst} but without\n"
- "duplicates.\n"
- "\n"
- "When elements are equal, only the first in @var{lst} is\n"
- "retained. Equal elements can be anywhere in @var{lst}, they\n"
- "don't have to be adjacent. The returned list will have the\n"
- "retained elements in the same order as they were in @var{lst}.\n"
- "\n"
- "Equality is determined by @var{pred}, or @code{equal?} if not\n"
- "given. Calls @code{(pred x y)} are made with element @var{x}\n"
- "being before @var{y} in @var{lst}. A call is made at most once\n"
- "for each combination, but the sequence of the calls across the\n"
- "elements is unspecified.\n"
- "\n"
- "@var{lst} is not modified, but the return might share a common\n"
- "tail with @var{lst}.\n"
- "\n"
- "In the worst case, this is an @math{O(N^2)} algorithm because\n"
- "it must check each element against all those preceding it. For\n"
- "long lists it is more efficient to sort and then compare only\n"
- "adjacent elements.")
-#define FUNC_NAME s_scm_srfi1_delete_duplicates
-{
- scm_t_trampoline_2 equal_p;
- SCM ret, *p, keeplst, item, l;
- int count, i;
-
- /* ret is the new list constructed. p is where to append, initially &ret
- then SCM_CDRLOC of the last pair. lst is advanced as each element is
- considered.
-
- Elements retained are not immediately appended to ret, instead keeplst
- is the last pair in lst which is to be kept but is not yet copied.
- Initially this is the first pair of lst, since the first element is
- always retained.
-
- *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
- the elements retained, making the equality search loop easy.
-
- If an item must be deleted, elements from keeplst (inclusive) to lst
- (exclusive) must be copied and appended to ret. When there's no more
- deletions, *p is left set to keeplst, so ret shares structure with the
- original lst. (ret will be the entire original lst if there are no
- deletions.) */
-
- /* skip to end if an empty list (or something invalid) */
- ret = SCM_EOL;
-
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- SCM_VALIDATE_PROC (SCM_ARG2, pred);
- equal_p = scm_call_2;
- }
-
- keeplst = lst;
- count = 0;
- p = &ret;
-
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- item = SCM_CAR (lst);
-
- /* look for item in "ret" list */
- for (l = ret; scm_is_pair (l); l = SCM_CDR (l))
- {
- if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
- {
- /* "item" is a duplicate, so copy keeplst onto ret */
- duplicate:
- p = list_copy_part (keeplst, count, p);
-
- keeplst = SCM_CDR (lst); /* elem after the one deleted */
- count = 0;
- goto next_elem;
- }
- }
-
- /* look for item in "keeplst" list
- be careful traversing, in case nasty code changed the cdrs */
- for (i = 0, l = keeplst;
- i < count && scm_is_pair (l);
- i++, l = SCM_CDR (l))
- if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
- goto duplicate;
-
- /* keep this element */
- count++;
-
- next_elem:
- ;
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
-
- /* share tail of keeplst items */
- *p = keeplst;
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
- (SCM lst, SCM pred),
- "Return a list containing the elements of @var{lst} but without\n"
- "duplicates.\n"
- "\n"
- "When elements are equal, only the first in @var{lst} is\n"
- "retained. Equal elements can be anywhere in @var{lst}, they\n"
- "don't have to be adjacent. The returned list will have the\n"
- "retained elements in the same order as they were in @var{lst}.\n"
- "\n"
- "Equality is determined by @var{pred}, or @code{equal?} if not\n"
- "given. Calls @code{(pred x y)} are made with element @var{x}\n"
- "being before @var{y} in @var{lst}. A call is made at most once\n"
- "for each combination, but the sequence of the calls across the\n"
- "elements is unspecified.\n"
- "\n"
- "@var{lst} may be modified to construct the returned list.\n"
- "\n"
- "In the worst case, this is an @math{O(N^2)} algorithm because\n"
- "it must check each element against all those preceding it. For\n"
- "long lists it is more efficient to sort and then compare only\n"
- "adjacent elements.")
-#define FUNC_NAME s_scm_srfi1_delete_duplicates_x
-{
- scm_t_trampoline_2 equal_p;
- SCM ret, endret, item, l;
-
- /* ret is the return list, constructed from the pairs in lst. endret is
- the last pair of ret, initially the first pair. lst is advanced as
- elements are considered. */
-
- /* skip to end if an empty list (or something invalid) */
- ret = lst;
- if (scm_is_pair (lst))
- {
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- SCM_VALIDATE_PROC (SCM_ARG2, pred);
- equal_p = scm_call_2;
- }
-
- endret = ret;
-
- /* loop over lst elements starting from second */
- for (;;)
- {
- lst = SCM_CDR (lst);
- if (! scm_is_pair (lst))
- break;
- item = SCM_CAR (lst);
-
- /* is item equal to any element from ret to endret (inclusive)? */
- l = ret;
- for (;;)
- {
- if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
- break; /* equal, forget this element */
-
- if (scm_is_eq (l, endret))
- {
- /* not equal to any, so append this pair */
- scm_set_cdr_x (endret, lst);
- endret = lst;
- break;
- }
- l = SCM_CDR (l);
- }
- }
-
- /* terminate, in case last element was deleted */
- scm_set_cdr_x (endret, SCM_EOL);
- }
-
- /* demand that lst was a proper list */
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
-
- return ret;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
- (SCM lst),
- "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
- "circular.")
-#define FUNC_NAME s_scm_srfi1_length_plus
-{
- size_t i = 0;
- SCM tortoise = lst;
- SCM hare = lst;
-
- do
- {
- if (!scm_is_pair (hare))
- {
- if (SCM_NULL_OR_NIL_P (hare))
- return scm_from_size_t (i);
- else
- scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
- "proper or circular list");
- }
- hare = SCM_CDR (hare);
- i++;
- if (!scm_is_pair (hare))
- {
- if (SCM_NULL_OR_NIL_P (hare))
- return scm_from_size_t (i);
- else
- scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
- "proper or circular list");
- }
- hare = SCM_CDR (hare);
- i++;
- /* For every two steps the hare takes, the tortoise takes one. */
- tortoise = SCM_CDR (tortoise);
- }
- while (!scm_is_eq (hare, tortoise));
-
- /* If the tortoise ever catches the hare, then the list must contain
- a cycle. */
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-/* This routine differs from the core list-copy in allowing improper lists.
- Maybe the core could allow them similarly. */
-
-SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
- (SCM lst),
- "Return a copy of the given list @var{lst}.\n"
- "\n"
- "@var{lst} can be a proper or improper list. And if @var{lst}\n"
- "is not a pair then it's treated as the final tail of an\n"
- "improper list and simply returned.")
-#define FUNC_NAME s_scm_srfi1_list_copy
-{
- SCM newlst;
- SCM * fill_here;
- SCM from_here;
-
- newlst = lst;
- fill_here = &newlst;
- from_here = lst;
-
- while (scm_is_pair (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
-
-SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
- (SCM equal, SCM lst, SCM rest),
- "Return @var{lst} with any elements in the lists in @var{rest}\n"
- "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
- "just that list is returned.\n"
- "\n"
- "The given @var{equal} procedure is used for comparing elements,\n"
- "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
- "is from @var{lst} and the second from one of the subsequent\n"
- "lists. But exactly which calls are made and in what order is\n"
- "unspecified.\n"
- "\n"
- "@example\n"
- "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
- "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
- "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
- "@end example\n"
- "\n"
- "@code{lset-difference!} may modify @var{lst} to form its\n"
- "result.")
-#define FUNC_NAME s_scm_srfi1_lset_difference_x
-{
- SCM ret, *pos, elem, r, b;
- int argnum;
-
- SCM_VALIDATE_PROC (SCM_ARG1, equal);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- ret = SCM_EOL;
- pos = &ret;
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- elem = SCM_CAR (lst);
-
- for (r = rest, argnum = SCM_ARG3;
- scm_is_pair (r);
- r = SCM_CDR (r), argnum++)
- {
- for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
- if (scm_is_true (scm_call_2 (equal, elem, SCM_CAR (b))))
- goto next_elem; /* equal to elem, so drop that elem */
-
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
- }
-
- /* elem not equal to anything in later lists, so keep it */
- *pos = lst;
- pos = SCM_CDRLOC (lst);
-
- next_elem:
- ;
- }
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- *pos = SCM_EOL;
- return ret;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
- (SCM pred, SCM list),
- "Partition the elements of @var{list} with predicate @var{pred}.\n"
- "Return two values: the list of elements satisfying @var{pred} and\n"
- "the list of elements @emph{not} satisfying @var{pred}. The order\n"
- "of the output lists follows the order of @var{list}. @var{list}\n"
- "is not mutated. One of the output lists may share memory with @var{list}.\n")
-#define FUNC_NAME s_scm_srfi1_partition
-{
- /* In this implementation, the output lists don't share memory with
- list, because it's probably not worth the effort. */
- SCM orig_list = list;
- SCM kept = scm_cons(SCM_EOL, SCM_EOL);
- SCM kept_tail = kept;
- SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
- SCM dropped_tail = dropped;
-
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
- for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
- SCM elt, new_tail;
-
- /* Make sure LIST is not a dotted list. */
- SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
-
- elt = SCM_CAR (list);
- new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
-
- if (scm_is_true (scm_call_1 (pred, elt))) {
- SCM_SETCDR(kept_tail, new_tail);
- kept_tail = new_tail;
- }
- else {
- SCM_SETCDR(dropped_tail, new_tail);
- dropped_tail = new_tail;
- }
- }
- return scm_values_2 (SCM_CDR (kept), SCM_CDR (dropped));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
- (SCM pred, SCM lst),
- "Split @var{lst} into those elements which do and don't satisfy\n"
- "the predicate @var{pred}.\n"
- "\n"
- "The return is two values (@pxref{Multiple Values}), the first\n"
- "being a list of all elements from @var{lst} which satisfy\n"
- "@var{pred}, the second a list of those which do not.\n"
- "\n"
- "The elements in the result lists are in the same order as in\n"
- "@var{lst} but the order in which the calls @code{(@var{pred}\n"
- "elem)} are made on the list elements is unspecified.\n"
- "\n"
- "@var{lst} may be modified to construct the return lists.")
-#define FUNC_NAME s_scm_srfi1_partition_x
-{
- SCM tlst, flst, *tp, *fp;
-
- SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
- /* tlst and flst are the lists of true and false elements. tp and fp are
- where to store to append to them, initially &tlst and &flst, then
- SCM_CDRLOC of the last pair in the respective lists. */
-
- tlst = SCM_EOL;
- flst = SCM_EOL;
- tp = &tlst;
- fp = &flst;
-
- for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
- {
- if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
- {
- *tp = lst;
- tp = SCM_CDRLOC (lst);
- }
- else
- {
- *fp = lst;
- fp = SCM_CDRLOC (lst);
- }
- }
-
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
- /* terminate whichever didn't get the last element(s) */
- *tp = SCM_EOL;
- *fp = SCM_EOL;
-
- return scm_values_2 (tlst, flst);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
- (SCM pred, SCM list),
- "Return a list containing all elements from @var{list} which do\n"
- "not satisfy the predicate @var{pred}. The elements in the\n"
- "result list have the same order as in @var{list}. The order in\n"
- "which @var{pred} is applied to the list elements is not\n"
- "specified.")
-#define FUNC_NAME s_scm_srfi1_remove
-{
- SCM walk;
- SCM *prev;
- SCM res = SCM_EOL;
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
- SCM_VALIDATE_LIST (2, list);
-
- for (prev = &res, walk = list;
- scm_is_pair (walk);
- walk = SCM_CDR (walk))
- {
- if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
- {
- *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
- prev = SCM_CDRLOC (*prev);
- }
- }
-
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
- (SCM pred, SCM list),
- "Return a list containing all elements from @var{list} which do\n"
- "not satisfy the predicate @var{pred}. The elements in the\n"
- "result list have the same order as in @var{list}. The order in\n"
- "which @var{pred} is applied to the list elements is not\n"
- "specified. @var{list} may be modified to build the return\n"
- "list.")
-#define FUNC_NAME s_scm_srfi1_remove_x
-{
- SCM walk;
- SCM *prev;
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
- SCM_VALIDATE_LIST (2, list);
-
- for (prev = &list, walk = list;
- scm_is_pair (walk);
- walk = SCM_CDR (walk))
- {
- if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
- prev = SCM_CDRLOC (walk);
- else
- *prev = SCM_CDR (walk);
- }
-
- return list;
-}
-#undef FUNC_NAME
-
-
-void
-scm_register_srfi_1 (void)
-{
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_srfi_1",
- (scm_t_extension_init_func)scm_init_srfi_1, NULL);
-}
-
-void
-scm_init_srfi_1 (void)
-{
-#ifndef SCM_MAGIC_SNARFER
-#include "srfi-1.x"
-#endif
-}
-
-/* End of srfi-1.c. */
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
deleted file mode 100644
index 9dafb9c0d..000000000
--- a/libguile/srfi-1.h
+++ /dev/null
@@ -1,47 +0,0 @@
-/* srfi-1.h --- SRFI-1 procedures for Guile
- Copyright 2002-2003,2005-2006,2010-2011,2018,2020
- Free Software Foundation, Inc.
-
- This file is part of Guile.
-
- Guile is free software: you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- Guile 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 Lesser General Public
- License for more details.
-
- You should have received a copy of the GNU Lesser General Public
- License along with Guile. If not, see
- <https://www.gnu.org/licenses/>. */
-
-
-#ifndef SCM_SRFI_1_H
-#define SCM_SRFI_1_H
-
-#include "libguile/scm.h"
-
-SCM_INTERNAL SCM scm_srfi1_append_reverse (SCM revhead, SCM tail);
-SCM_INTERNAL SCM scm_srfi1_append_reverse_x (SCM revhead, SCM tail);
-SCM_INTERNAL SCM scm_srfi1_concatenate (SCM lstlst);
-SCM_INTERNAL SCM scm_srfi1_concatenate_x (SCM lstlst);
-SCM_INTERNAL SCM scm_srfi1_count (SCM pred, SCM list1, SCM rest);
-SCM_INTERNAL SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
-SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
-SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst);
-SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
-SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
-SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list);
-SCM_INTERNAL SCM scm_srfi1_remove_x (SCM pred, SCM list);
-
-SCM_INTERNAL void scm_register_srfi_1 (void);
-SCM_INTERNAL void scm_init_srfi_1 (void);
-
-#endif /* SCM_SRFI_1_H */