summaryrefslogtreecommitdiff
path: root/srfi/srfi-1.c
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2010-07-13 00:07:12 +0200
committerLudovic Courtès <ludo@gnu.org>2010-07-21 01:07:56 +0200
commit0b7f2eb8bf5002c91dec6267afb451ee6e3bf7c1 (patch)
treefd4a85fa48234271610f7da0f0f4c80d157b1fc7 /srfi/srfi-1.c
parent927bf5e8cc0af9515797ebab6d9ba162bef23c2a (diff)
downloadguile-0b7f2eb8bf5002c91dec6267afb451ee6e3bf7c1.tar.gz
Start rewriting SRFI-1 in Scheme.
This partially reverts commit e556f8c3c6b74ee6596e8dcbe829109d7745da2c (Fri May 6 2005). * module/srfi/srfi-1.scm (xcons, list-tabulate, not-pair?, car+cdr, last, fold, list-index): New procedures. * srfi/srfi-1.c (srfi1_module): New variable. (CACHE_VAR): New macro. (scm_srfi1_car_plus_cdr, scm_srfi1_fold, scm_srfi1_last, scm_srfi1_list_index, scm_srfi1_list_tabulate, scm_srfi1_not_pair_p, scm_srfi1_xcons): Rewrite as proxies of the corresponding Scheme procedure. * test-suite/tests/srfi-1.test ("list-tabulate")["-1"]: Change exception type to `exception:wrong-type-arg'. * benchmark-suite/benchmarks/srfi-1.bm: New file. * benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add `benchmarks/srfi-1.bm'. * test-suite/standalone/Makefile.am (test_srfi_1_SOURCES, test_srfi_1_CFLAGS, test_srfi_1_LDADD): New variables. (check_PROGRAMS): Add `test-srfi-1'. (TESTS): Ditto. * test-suite/standalone/test-srfi-1.c: New file.
Diffstat (limited to 'srfi/srfi-1.c')
-rw-r--r--srfi/srfi-1.c320
1 files changed, 53 insertions, 267 deletions
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 537c2b328..44db0e3f6 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -27,13 +27,34 @@
#include "srfi-1.h"
-/* The intent of this file is to gradually replace those Scheme
- * procedures in srfi-1.scm which extends core primitive procedures,
+/* 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 won't have performance penalties.
*
- * Please feel free to contribute any new replacements!
+ * However, we now prefer to write these procedures in Scheme, let the compiler
+ * optimize them, and have the VM execute them efficiently.
*/
+
+/* The `(srfi srfi-1)' module. */
+static SCM srfi1_module = SCM_BOOL_F;
+
+/* Cache variable NAME in C variable VAR. */
+#define CACHE_VAR(var, name) \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ { \
+ if (SCM_UNLIKELY (scm_is_false (srfi1_module))) \
+ srfi1_module = scm_c_resolve_module ("srfi srfi-1"); \
+ \
+ var = scm_module_variable (srfi1_module, \
+ scm_from_locale_symbol (name)); \
+ if (SCM_UNLIKELY (scm_is_false (var))) \
+ abort (); \
+ \
+ var = SCM_VARIABLE_REF (var); \
+ }
+
static long
srfi1_ilength (SCM sx)
{
@@ -253,16 +274,12 @@ SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0,
- (SCM pair),
- "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
-#define FUNC_NAME s_scm_srfi1_car_plus_cdr
+SCM
+scm_srfi1_car_plus_cdr (SCM pair)
{
- SCM_VALIDATE_CONS (SCM_ARG1, pair);
- return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair)));
+ CACHE_VAR (car_plus_cdr, "car+cdr");
+ return scm_call_1 (car_plus_cdr, pair);
}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
(SCM lstlst),
@@ -935,131 +952,19 @@ SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1,
- (SCM proc, SCM init, SCM list1, SCM rest),
- "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
- "@var{lstN} to build a result, and return that result.\n"
- "\n"
- "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
- "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
- "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
- "@var{previous} is the return from the previous call to\n"
- "@var{proc}, or the given @var{init} for the first call. If any\n"
- "list is empty, just @var{init} is returned.\n"
- "\n"
- "@code{fold} works through the list elements from first to last.\n"
- "The following shows a list reversal and the calls it makes,\n"
- "\n"
- "@example\n"
- "(fold cons '() '(1 2 3))\n"
- "\n"
- "(cons 1 '())\n"
- "(cons 2 '(1))\n"
- "(cons 3 '(2 1)\n"
- "@result{} (3 2 1)\n"
- "@end example\n"
- "\n"
- "If @var{lst1} through @var{lstN} have different lengths,\n"
- "@code{fold} stops when the end of the shortest is reached.\n"
- "Ie.@: elements past the length of the shortest are ignored in\n"
- "the other @var{lst}s. At least one @var{lst} must be\n"
- "non-circular.\n"
- "\n"
- "The way @code{fold} builds a result from iterating is quite\n"
- "general, it can do more than other iterations like say\n"
- "@code{map} or @code{filter}. The following for example removes\n"
- "adjacent duplicate elements from a list,\n"
- "\n"
- "@example\n"
- "(define (delete-adjacent-duplicates lst)\n"
- " (fold-right (lambda (elem ret)\n"
- " (if (equal? elem (first ret))\n"
- " ret\n"
- " (cons elem ret)))\n"
- " (list (last lst))\n"
- " lst))\n"
- "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
- "@result{} (1 2 3 4 5)\n"
- "@end example\n"
- "\n"
- "Clearly the same sort of thing can be done with a\n"
- "@code{for-each} and a variable in which to build the result,\n"
- "but a self-contained @var{proc} can be re-used in multiple\n"
- "contexts, where a @code{for-each} would have to be written out\n"
- "each time.")
-#define FUNC_NAME s_scm_srfi1_fold
+SCM
+scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest)
{
- SCM lst;
- int argnum;
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- if (scm_is_null (rest))
- {
- /* one list */
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
- init = scm_call_2 (proc, SCM_CAR (list1), init);
-
- /* check below that list1 is a proper list, and done */
- lst = list1;
- argnum = 2;
- }
- else
- {
- /* two 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 proc, same length as vec,
- re-used for each call */
- args = scm_make_list (SCM_I_MAKINUM (len+1), 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 proc */
- SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
- }
- SCM_SETCAR (a, init);
-
- init = scm_apply (proc, args, SCM_EOL);
- }
- }
-
- check_lst_and_done:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
- return init;
+ CACHE_VAR (fold, "fold");
+ return scm_apply_3 (fold, proc, init, list1, rest);
}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0,
- (SCM lst),
- "Like @code{cons}, but with interchanged arguments. Useful\n"
- "mostly when passed to higher-order procedures.")
-#define FUNC_NAME s_scm_srfi1_last
+SCM
+scm_srfi1_last (SCM lst)
{
- SCM pair = scm_last_pair (lst);
- /* scm_last_pair returns SCM_EOL for an empty list */
- SCM_VALIDATE_CONS (SCM_ARG1, pair);
- return SCM_CAR (pair);
+ CACHE_VAR (last, "last");
+ return scm_call_1 (last, lst);
}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
(SCM lst),
@@ -1073,106 +978,12 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1,
- (SCM pred, SCM list1, SCM rest),
- "Return the index of the first set of elements, one from each of\n"
- "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n"
- "\n"
- "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
- "elemN)}. Searching stops when the end of the shortest\n"
- "@var{lst} is reached. The return index starts from 0 for the\n"
- "first set of elements. If no set of elements pass then the\n"
- "return is @code{#f}.\n"
- "\n"
- "@example\n"
- "(list-index odd? '(2 4 6 9)) @result{} 3\n"
- "(list-index = '(1 2 3) '(3 1 2)) @result{} #f\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi1_list_index
+SCM
+scm_srfi1_list_index (SCM pred, SCM list1, SCM rest)
{
- long n = 0;
- SCM lst;
- int argnum;
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- if (scm_is_null (rest))
- {
- /* one list */
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
- for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
- if (scm_is_true (scm_call_1 (pred, SCM_CAR (list1))))
- return SCM_I_MAKINUM (n);
-
- /* not found, check below that list1 is a proper list */
- end_list1:
- lst = list1;
- argnum = 2;
- }
- else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
- {
- /* two lists */
- SCM list2 = SCM_CAR (rest);
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
- for ( ; ; n++)
- {
- if (! scm_is_pair (list1))
- goto end_list1;
- if (! scm_is_pair (list2))
- {
- lst = list2;
- argnum = 3;
- break;
- }
- if (scm_is_true (scm_call_2 (pred,
- SCM_CAR (list1), SCM_CAR (list2))))
- return SCM_I_MAKINUM (n);
-
- 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 ( ; ; n++)
- {
- /* 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 not_found_check_lst;
- SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
- SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
- }
-
- if (scm_is_true (scm_apply (pred, args, SCM_EOL)))
- return SCM_I_MAKINUM (n);
- }
- }
-
- not_found_check_lst:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
- return SCM_BOOL_F;
+ CACHE_VAR (list_index, "list-index");
+ return scm_apply_2 (list_index, pred, list1, rest);
}
-#undef FUNC_NAME
-
/* This routine differs from the core list-copy in allowing improper lists.
Maybe the core could allow them similarly. */
@@ -1206,25 +1017,12 @@ SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0,
- (SCM n, SCM proc),
- "Return an @var{n}-element list, where each list element is\n"
- "produced by applying the procedure @var{init-proc} to the\n"
- "corresponding list index. The order in which @var{init-proc}\n"
- "is applied to the indices is not specified.")
-#define FUNC_NAME s_scm_srfi1_list_tabulate
+SCM
+scm_srfi1_list_tabulate (SCM n, SCM proc)
{
- long i, nn;
- SCM ret = SCM_EOL;
- nn = scm_to_signed_integer (n, 0, LONG_MAX);
- SCM_VALIDATE_PROC (SCM_ARG2, proc);
- for (i = nn-1; i >= 0; i--)
- ret = scm_cons (scm_call_1 (proc, scm_from_long (i)), ret);
- return ret;
+ CACHE_VAR (list_tabulate, "list-tabulate");
+ return scm_call_2 (list_tabulate, n, proc);
}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
(SCM equal, SCM lst, SCM rest),
@@ -1609,21 +1407,12 @@ SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
- "otherwise.\n"
- "\n"
- "This is shorthand notation @code{(not (pair? @var{obj}))} and\n"
- "is supposed to be used for end-of-list checking in contexts\n"
- "where dotted lists are allowed.")
-#define FUNC_NAME s_scm_srfi1_not_pair_p
+SCM
+scm_srfi1_not_pair_p (SCM obj)
{
- return scm_from_bool (! scm_is_pair (obj));
+ CACHE_VAR (not_pair_p, "not-pair?");
+ return scm_call_1 (not_pair_p, obj);
}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
(SCM pred, SCM list),
@@ -2153,17 +1942,14 @@ SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0,
- (SCM d, SCM a),
- "Like @code{cons}, but with interchanged arguments. Useful\n"
- "mostly when passed to higher-order procedures.")
-#define FUNC_NAME s_scm_srfi1_xcons
+SCM
+scm_srfi1_xcons (SCM d, SCM a)
{
- return scm_cons (a, d);
+ CACHE_VAR (xcons, "xcons");
+ return scm_call_2 (xcons, d, a);
}
-#undef FUNC_NAME
-
+
void
scm_init_srfi_1 (void)
{