mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

remove uses of trampolines within guile itself

Browse source 
* libguile/eval.c (scm_map, scm_for_each)
* libguile/hashtab.c (scm_hash_for_each_handle)
* libguile/list.c (scm_filter, scm_filter_x)
* libguile/quicksort.i.c:
* libguile/sort.c (scm_restricted_vector_sort_x, scm_sorted_p)
  (scm_merge, scm_merge_list_x, scm_merge_x)
  (scm_merge_list_step, scm_sort_x, scm_sort, scm_merge_vector_x)
  (scm_merge_vector_step, scm_stable_sort_x, scm_sort_list_x)
  (scm_sort_list)nn
* libguile/srfi-13.c (scm_string_any, scm_string_every)
  (scm_string_tabulate, scm_string_trim, string_trim_right)
  (scm_string_trim_both, scm_string_index, scm_string_index_right)
  (scm_string_skip, scm_string_skip_right, scm_string_count)
  (scm_string_map, scm_string_map_x, scm_string_for_each)
  (scm_string_for_each_index, scm_string_filter, scm_string_delete):
  Remove uses of trampolines.
This commit is contained in:
Andy Wingo 2009-11-27 18:13:59 +01:00
parent b3f04491ee
commit 6c9e8a5354
6 changed files with 101 additions and 126 deletions
Download patch file Download diff file Expand all files Collapse all files

23
libguile/eval.c
View file

@ -3268,11 +3268,10 @@ scm_map (SCM proc, SCM arg1, SCM args)
SCM_VALIDATE_REST_ARGUMENT (args); SCM_VALIDATE_REST_ARGUMENT (args);
if (scm_is_null (args)) if (scm_is_null (args))
{ {
scm_t_trampoline_1 call = scm_trampoline_1 (proc); SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_map, proc, arg1, SCM_ARG1, s_map);
SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map);
while (SCM_NIMP (arg1)) while (SCM_NIMP (arg1))
{ {
*pres = scm_list_1 (call (proc, SCM_CAR (arg1))); *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1)));
pres = SCM_CDRLOC (*pres); pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1); arg1 = SCM_CDR (arg1);
} }
@ -3282,16 +3281,15 @@ scm_map (SCM proc, SCM arg1, SCM args)
{ {
SCM arg2 = SCM_CAR (args); SCM arg2 = SCM_CAR (args);
int len2 = scm_ilength (arg2); int len2 = scm_ilength (arg2);
scm_t_trampoline_2 call = scm_trampoline_2 (proc); SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_map,
SCM_GASSERTn (call, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
SCM_GASSERTn (len2 >= 0, SCM_GASSERTn (len2 >= 0,
g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map); g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
if (len2 != len) if (len2 != len)
SCM_OUT_OF_RANGE (3, arg2); SCM_OUT_OF_RANGE (3, arg2);
while (SCM_NIMP (arg1)) while (SCM_NIMP (arg1))
{ {
*pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2))); *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
pres = SCM_CDRLOC (*pres); pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1); arg1 = SCM_CDR (arg1);
arg2 = SCM_CDR (arg2); arg2 = SCM_CDR (arg2);
@ -3332,11 +3330,11 @@ scm_for_each (SCM proc, SCM arg1, SCM args)
SCM_VALIDATE_REST_ARGUMENT (args); SCM_VALIDATE_REST_ARGUMENT (args);
if (scm_is_null (args)) if (scm_is_null (args))
{ {
scm_t_trampoline_1 call = scm_trampoline_1 (proc); SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_for_each,
SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each); proc, arg1, SCM_ARG1, s_for_each);
while (SCM_NIMP (arg1)) while (SCM_NIMP (arg1))
{ {
call (proc, SCM_CAR (arg1)); scm_call_1 (proc, SCM_CAR (arg1));
arg1 = SCM_CDR (arg1); arg1 = SCM_CDR (arg1);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -3345,8 +3343,7 @@ scm_for_each (SCM proc, SCM arg1, SCM args)
{ {
SCM arg2 = SCM_CAR (args); SCM arg2 = SCM_CAR (args);
int len2 = scm_ilength (arg2); int len2 = scm_ilength (arg2);
scm_t_trampoline_2 call = scm_trampoline_2 (proc); SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_for_each,
SCM_GASSERTn (call, g_for_each,
scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each); scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
SCM_GASSERTn (len2 >= 0, g_for_each, SCM_GASSERTn (len2 >= 0, g_for_each,
scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each); scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
@ -3354,7 +3351,7 @@ scm_for_each (SCM proc, SCM arg1, SCM args)
SCM_OUT_OF_RANGE (3, arg2); SCM_OUT_OF_RANGE (3, arg2);
while (SCM_NIMP (arg1)) while (SCM_NIMP (arg1))
{ {
call (proc, SCM_CAR (arg1), SCM_CAR (arg2)); scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2));
arg1 = SCM_CDR (arg1); arg1 = SCM_CDR (arg1);
arg2 = SCM_CDR (arg2); arg2 = SCM_CDR (arg2);
} }

5
libguile/hashtab.c
View file

@ -1220,12 +1220,11 @@ SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
"Applies PROC successively on all hash table handles.") "Applies PROC successively on all hash table handles.")
#define FUNC_NAME s_scm_hash_for_each_handle #define FUNC_NAME s_scm_hash_for_each_handle
{ {
scm_t_trampoline_1 call = scm_trampoline_1 (proc); SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
SCM_ASSERT (call, proc, 1, FUNC_NAME);
if (!SCM_HASHTABLE_P (table)) if (!SCM_HASHTABLE_P (table))
SCM_VALIDATE_VECTOR (2, table); SCM_VALIDATE_VECTOR (2, table);
scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) call, scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(void *) SCM_UNPACK (proc), (void *) SCM_UNPACK (proc),
table); table);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;

12
libguile/list.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008 /* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009
* Free Software Foundation, Inc. * Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
@ -885,18 +885,17 @@ SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
"@end lisp") "@end lisp")
#define FUNC_NAME s_scm_filter #define FUNC_NAME s_scm_filter
{ {
scm_t_trampoline_1 call = scm_trampoline_1 (pred);
SCM walk; SCM walk;
SCM *prev; SCM *prev;
SCM res = SCM_EOL; SCM res = SCM_EOL;
SCM_ASSERT (call, pred, 1, FUNC_NAME); SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
SCM_VALIDATE_LIST (2, list); SCM_VALIDATE_LIST (2, list);
for (prev = &res, walk = list; for (prev = &res, walk = list;
scm_is_pair (walk); scm_is_pair (walk);
walk = SCM_CDR (walk)) walk = SCM_CDR (walk))
{ {
if (scm_is_true (call (pred, SCM_CAR (walk)))) if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
{ {
*prev = scm_cons (SCM_CAR (walk), SCM_EOL); *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
prev = SCM_CDRLOC (*prev); prev = SCM_CDRLOC (*prev);
@ -912,17 +911,16 @@ SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
"Linear-update variant of @code{filter}.") "Linear-update variant of @code{filter}.")
#define FUNC_NAME s_scm_filter_x #define FUNC_NAME s_scm_filter_x
{ {
scm_t_trampoline_1 call = scm_trampoline_1 (pred);
SCM walk; SCM walk;
SCM *prev; SCM *prev;
SCM_ASSERT (call, pred, 1, FUNC_NAME); SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, 1, FUNC_NAME);
SCM_VALIDATE_LIST (2, list); SCM_VALIDATE_LIST (2, list);
for (prev = &list, walk = list; for (prev = &list, walk = list;
scm_is_pair (walk); scm_is_pair (walk);
walk = SCM_CDR (walk)) walk = SCM_CDR (walk))
{ {
if (scm_is_true (call (pred, SCM_CAR (walk)))) if (scm_is_true (scm_call_1 (pred, SCM_CAR (walk))))
prev = SCM_CDRLOC (walk); prev = SCM_CDRLOC (walk);
else else
*prev = SCM_CDR (walk); *prev = SCM_CDR (walk);

16
libguile/quicksort.i.c
View file

@ -55,7 +55,7 @@
static void static void
NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
scm_t_trampoline_2 cmp, SCM less) SCM less)
{ {
/* Stack node declarations used to store unfulfilled partition obligations. */ /* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct { typedef struct {
@ -93,13 +93,13 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK; SCM_TICK;
if (scm_is_true ((*cmp) (less, ELT(mid), ELT(lo)))) if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
SWAP (ELT(mid), ELT(lo)); SWAP (ELT(mid), ELT(lo));
if (scm_is_true ((*cmp) (less, ELT(hi), ELT(mid)))) if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid))))
SWAP (ELT(mid), ELT(hi)); SWAP (ELT(mid), ELT(hi));
else else
goto jump_over; goto jump_over;
if (scm_is_true ((*cmp) (less, ELT(mid), ELT(lo)))) if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
SWAP (ELT(mid), ELT(lo)); SWAP (ELT(mid), ELT(lo));
jump_over:; jump_over:;
@ -112,7 +112,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
that this algorithm runs much faster than others. */ that this algorithm runs much faster than others. */
do do
{ {
while (scm_is_true ((*cmp) (less, ELT(left), pivot))) while (scm_is_true (scm_call_2 (less, ELT(left), pivot)))
{ {
left += 1; left += 1;
/* The comparison predicate may be buggy */ /* The comparison predicate may be buggy */
@ -120,7 +120,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
scm_misc_error (NULL, s_buggy_less, SCM_EOL); scm_misc_error (NULL, s_buggy_less, SCM_EOL);
} }
while (scm_is_true ((*cmp) (less, pivot, ELT(right)))) while (scm_is_true (scm_call_2 (less, pivot, ELT(right))))
{ {
right -= 1; right -= 1;
/* The comparison predicate may be buggy */ /* The comparison predicate may be buggy */
@ -192,7 +192,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
and the operation speeds up insertion sort's inner loop. */ and the operation speeds up insertion sort's inner loop. */
for (run = tmp + 1; run <= thresh; run += 1) for (run = tmp + 1; run <= thresh; run += 1)
if (scm_is_true ((*cmp) (less, ELT(run), ELT(tmp)))) if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
tmp = run; tmp = run;
if (tmp != 0) if (tmp != 0)
@ -206,7 +206,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK; SCM_TICK;
tmp = run - 1; tmp = run - 1;
while (scm_is_true ((*cmp) (less, ELT(run), ELT(tmp)))) while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
{ {
/* The comparison predicate may be buggy */ /* The comparison predicate may be buggy */
if (tmp == 0) if (tmp == 0)

66
libguile/sort.c
View file

@ -65,14 +65,6 @@
#define INC inc #define INC inc
#include "libguile/quicksort.i.c" #include "libguile/quicksort.i.c"
static scm_t_trampoline_2
compare_function (SCM less, unsigned int arg_nr, const char* fname)
{
const scm_t_trampoline_2 cmp = scm_trampoline_2 (less);
SCM_ASSERT_TYPE (cmp != NULL, less, arg_nr, fname, "less predicate");
return cmp;
}
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos), (SCM vec, SCM less, SCM startpos, SCM endpos),
@ -83,7 +75,6 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
"is not specified.") "is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x #define FUNC_NAME s_scm_restricted_vector_sort_x
{ {
const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
size_t vlen, spos, len; size_t vlen, spos, len;
ssize_t vinc; ssize_t vinc;
scm_t_array_handle handle; scm_t_array_handle handle;
@ -94,9 +85,9 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
len = scm_to_unsigned_integer (endpos, spos, vlen) - spos; len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
if (vinc == 1) if (vinc == 1)
quicksort1 (velts + spos*vinc, len, cmp, less); quicksort1 (velts + spos*vinc, len, less);
else else
quicksort (velts + spos*vinc, len, vinc, cmp, less); quicksort (velts + spos*vinc, len, vinc, less);
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
@ -116,7 +107,6 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
"applied to all elements i - 1 and i") "applied to all elements i - 1 and i")
#define FUNC_NAME s_scm_sorted_p #define FUNC_NAME s_scm_sorted_p
{ {
const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len, j; /* list/vector length, temp j */ long len, j; /* list/vector length, temp j */
SCM item, rest; /* rest of items loop variable */ SCM item, rest; /* rest of items loop variable */
@ -135,7 +125,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
j = len - 1; j = len - 1;
while (j > 0) while (j > 0)
{ {
if (scm_is_true ((*cmp) (less, SCM_CAR (rest), item))) if (scm_is_true (scm_call_2 (less, SCM_CAR (rest), item)))
return SCM_BOOL_F; return SCM_BOOL_F;
else else
{ {
@ -158,7 +148,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
for (i = 1; i < len; i++, elts += inc) for (i = 1; i < len; i++, elts += inc)
{ {
if (scm_is_true ((*cmp) (less, elts[inc], elts[0]))) if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
{ {
result = SCM_BOOL_F; result = SCM_BOOL_F;
break; break;
@ -199,13 +189,12 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
return alist; return alist;
else else
{ {
const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
long alen, blen; /* list lengths */ long alen, blen; /* list lengths */
SCM last; SCM last;
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen); SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen); SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist)))) if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{ {
build = scm_cons (SCM_CAR (blist), SCM_EOL); build = scm_cons (SCM_CAR (blist), SCM_EOL);
blist = SCM_CDR (blist); blist = SCM_CDR (blist);
@ -221,7 +210,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
while ((alen > 0) && (blen > 0)) while ((alen > 0) && (blen > 0))
{ {
SCM_TICK; SCM_TICK;
if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist)))) if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{ {
SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL)); SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL));
blist = SCM_CDR (blist); blist = SCM_CDR (blist);
@ -248,7 +237,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
static SCM static SCM
scm_merge_list_x (SCM alist, SCM blist, scm_merge_list_x (SCM alist, SCM blist,
long alen, long blen, long alen, long blen,
scm_t_trampoline_2 cmp, SCM less) SCM less)
{ {
SCM build, last; SCM build, last;
@ -258,7 +247,7 @@ scm_merge_list_x (SCM alist, SCM blist,
return alist; return alist;
else else
{ {
if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist)))) if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{ {
build = blist; build = blist;
blist = SCM_CDR (blist); blist = SCM_CDR (blist);
@ -274,7 +263,7 @@ scm_merge_list_x (SCM alist, SCM blist,
while ((alen > 0) && (blen > 0)) while ((alen > 0) && (blen > 0))
{ {
SCM_TICK; SCM_TICK;
if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist)))) if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{ {
SCM_SETCDR (last, blist); SCM_SETCDR (last, blist);
blist = SCM_CDR (blist); blist = SCM_CDR (blist);
@ -314,11 +303,10 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
return alist; return alist;
else else
{ {
const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
long alen, blen; /* list lengths */ long alen, blen; /* list lengths */
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen); SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen); SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
return scm_merge_list_x (alist, blist, alen, blen, cmp, less); return scm_merge_list_x (alist, blist, alen, blen, less);
} }
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -330,7 +318,7 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
though it claimed to be. though it claimed to be.
*/ */
static SCM static SCM
scm_merge_list_step (SCM * seq, scm_t_trampoline_2 cmp, SCM less, long n) scm_merge_list_step (SCM * seq, SCM less, long n)
{ {
SCM a, b; SCM a, b;
@ -338,9 +326,9 @@ scm_merge_list_step (SCM * seq, scm_t_trampoline_2 cmp, SCM less, long n)
{ {
long mid = n / 2; long mid = n / 2;
SCM_TICK; SCM_TICK;
a = scm_merge_list_step (seq, cmp, less, mid); a = scm_merge_list_step (seq, less, mid);
b = scm_merge_list_step (seq, cmp, less, n - mid); b = scm_merge_list_step (seq, less, n - mid);
return scm_merge_list_x (a, b, mid, n - mid, cmp, less); return scm_merge_list_x (a, b, mid, n - mid, less);
} }
else if (n == 2) else if (n == 2)
{ {
@ -350,7 +338,7 @@ scm_merge_list_step (SCM * seq, scm_t_trampoline_2 cmp, SCM less, long n)
SCM y = SCM_CAR (SCM_CDR (*seq)); SCM y = SCM_CAR (SCM_CDR (*seq));
*seq = SCM_CDR (rest); *seq = SCM_CDR (rest);
SCM_SETCDR (rest, SCM_EOL); SCM_SETCDR (rest, SCM_EOL);
if (scm_is_true ((*cmp) (less, y, x))) if (scm_is_true (scm_call_2 (less, y, x)))
{ {
SCM_SETCAR (p, y); SCM_SETCAR (p, y);
SCM_SETCAR (rest, x); SCM_SETCAR (rest, x);
@ -384,9 +372,8 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
if (scm_is_pair (items)) if (scm_is_pair (items))
{ {
const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
SCM_VALIDATE_LIST_COPYLEN (1, items, len); SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, cmp, less, len); return scm_merge_list_step (&items, less, len);
} }
else if (scm_is_vector (items)) else if (scm_is_vector (items))
{ {
@ -425,7 +412,6 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
static void static void
scm_merge_vector_x (SCM *vec, scm_merge_vector_x (SCM *vec,
SCM *temp, SCM *temp,
scm_t_trampoline_2 cmp,
SCM less, SCM less,
size_t low, size_t low,
size_t mid, size_t mid,
@ -441,7 +427,7 @@ scm_merge_vector_x (SCM *vec,
/* Copy while both segments contain more characters */ /* Copy while both segments contain more characters */
for (it = low; (i1 <= mid) && (i2 <= high); ++it) for (it = low; (i1 <= mid) && (i2 <= high); ++it)
{ {
if (scm_is_true ((*cmp) (less, VEC(i2), VEC(i1)))) if (scm_is_true (scm_call_2 (less, VEC(i2), VEC(i1))))
temp[it] = VEC(i2++); temp[it] = VEC(i2++);
else else
temp[it] = VEC(i1++); temp[it] = VEC(i1++);
@ -466,7 +452,6 @@ scm_merge_vector_x (SCM *vec,
static void static void
scm_merge_vector_step (SCM *vec, scm_merge_vector_step (SCM *vec,
SCM *temp, SCM *temp,
scm_t_trampoline_2 cmp,
SCM less, SCM less,
size_t low, size_t low,
size_t high, size_t high,
@ -476,9 +461,9 @@ scm_merge_vector_step (SCM *vec,
{ {
size_t mid = (low + high) / 2; size_t mid = (low + high) / 2;
SCM_TICK; SCM_TICK;
scm_merge_vector_step (vec, temp, cmp, less, low, mid, inc); scm_merge_vector_step (vec, temp, less, low, mid, inc);
scm_merge_vector_step (vec, temp, cmp, less, mid+1, high, inc); scm_merge_vector_step (vec, temp, less, mid+1, high, inc);
scm_merge_vector_x (vec, temp, cmp, less, low, mid, high, inc); scm_merge_vector_x (vec, temp, less, low, mid, high, inc);
} }
} /* scm_merge_vector_step */ } /* scm_merge_vector_step */
@ -492,7 +477,6 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
"This is a stable sort.") "This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort_x #define FUNC_NAME s_scm_stable_sort_x
{ {
const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len; /* list/vector length */ long len; /* list/vector length */
if (SCM_NULL_OR_NIL_P (items)) if (SCM_NULL_OR_NIL_P (items))
@ -501,7 +485,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
if (scm_is_pair (items)) if (scm_is_pair (items))
{ {
SCM_VALIDATE_LIST_COPYLEN (1, items, len); SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, cmp, less, len); return scm_merge_list_step (&items, less, len);
} }
else if (scm_is_vector (items)) else if (scm_is_vector (items))
{ {
@ -516,7 +500,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
temp_elts = scm_vector_writable_elements (temp, &temp_handle, temp_elts = scm_vector_writable_elements (temp, &temp_handle,
NULL, NULL); NULL, NULL);
scm_merge_vector_step (vec_elts, temp_elts, cmp, less, 0, len-1, inc); scm_merge_vector_step (vec_elts, temp_elts, less, 0, len-1, inc);
scm_array_handle_release (&temp_handle); scm_array_handle_release (&temp_handle);
scm_array_handle_release (&vec_handle); scm_array_handle_release (&vec_handle);
@ -557,11 +541,10 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
"This is a stable sort.") "This is a stable sort.")
#define FUNC_NAME s_scm_sort_list_x #define FUNC_NAME s_scm_sort_list_x
{ {
const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len; long len;
SCM_VALIDATE_LIST_COPYLEN (1, items, len); SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, cmp, less, len); return scm_merge_list_step (&items, less, len);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -572,12 +555,11 @@ SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
"list elements. This is a stable sort.") "list elements. This is a stable sort.")
#define FUNC_NAME s_scm_sort_list #define FUNC_NAME s_scm_sort_list
{ {
const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len; long len;
SCM_VALIDATE_LIST_COPYLEN (1, items, len); SCM_VALIDATE_LIST_COPYLEN (1, items, len);
items = scm_list_copy (items); items = scm_list_copy (items);
return scm_merge_list_step (&items, cmp, less, len); return scm_merge_list_step (&items, less, len);
} }
#undef FUNC_NAME #undef FUNC_NAME

105
libguile/srfi-13.c
View file

@ -125,12 +125,12 @@ SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME); char_pred, SCM_ARG1, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
res = pred_tramp (char_pred, res = scm_call_1 (char_pred,
SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res)) if (scm_is_true (res))
break; break;
@ -192,12 +192,12 @@ SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME); char_pred, SCM_ARG1, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
res = pred_tramp (char_pred, res = scm_call_1 (char_pred,
SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res)) if (scm_is_false (res))
break; break;
@ -222,10 +222,9 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
size_t clen, i; size_t clen, i;
SCM res; SCM res;
SCM ch; SCM ch;
scm_t_trampoline_1 proc_tramp;
proc_tramp = scm_trampoline_1 (proc); SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME); proc, SCM_ARG1, FUNC_NAME);
SCM_ASSERT_RANGE (2, len, scm_to_int (len) >= 0); SCM_ASSERT_RANGE (2, len, scm_to_int (len) >= 0);
clen = scm_to_size_t (len); clen = scm_to_size_t (len);
@ -238,7 +237,7 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
i = 0; i = 0;
while (i < clen) while (i < clen)
{ {
ch = proc_tramp (proc, scm_from_size_t (i)); ch = scm_call_1 (proc, scm_from_size_t (i));
if (!SCM_CHARP (ch)) if (!SCM_CHARP (ch))
{ {
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
@ -745,14 +744,14 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
SCM res; SCM res;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res)) if (scm_is_false (res))
break; break;
cstart++; cstart++;
@ -820,14 +819,14 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
SCM res; SCM res;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res)) if (scm_is_false (res))
break; break;
cend--; cend--;
@ -913,14 +912,14 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
SCM res; SCM res;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res)) if (scm_is_false (res))
break; break;
cstart++; cstart++;
@ -929,7 +928,7 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
{ {
SCM res; SCM res;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res)) if (scm_is_false (res))
break; break;
cend--; cend--;
@ -1656,13 +1655,13 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
SCM res; SCM res;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res)) if (scm_is_true (res))
goto found; goto found;
cstart++; cstart++;
@ -1720,14 +1719,14 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
SCM res; SCM res;
cend--; cend--;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_true (res)) if (scm_is_true (res))
goto found; goto found;
} }
@ -1806,13 +1805,13 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
SCM res; SCM res;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res)) if (scm_is_false (res))
goto found; goto found;
cstart++; cstart++;
@ -1872,14 +1871,14 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
SCM res; SCM res;
cend--; cend--;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_false (res)) if (scm_is_false (res))
goto found; goto found;
} }
@ -1939,13 +1938,13 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
} }
else else
{ {
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
while (cstart < cend) while (cstart < cend)
{ {
SCM res; SCM res;
res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res)) if (scm_is_true (res))
count++; count++;
cstart++; cstart++;
@ -2452,9 +2451,9 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
size_t p; size_t p;
size_t cstart, cend; size_t cstart, cend;
SCM result; SCM result;
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME); SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s, MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart, 3, start, cstart,
4, end, cend); 4, end, cend);
@ -2462,7 +2461,7 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
p = 0; p = 0;
while (cstart < cend) while (cstart < cend)
{ {
SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart)); SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
if (!SCM_CHARP (ch)) if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
cstart++; cstart++;
@ -2486,15 +2485,15 @@ SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
#define FUNC_NAME s_scm_string_map_x #define FUNC_NAME s_scm_string_map_x
{ {
size_t cstart, cend; size_t cstart, cend;
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME); SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s, MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart, 3, start, cstart,
4, end, cend); 4, end, cend);
while (cstart < cend) while (cstart < cend)
{ {
SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart)); SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
if (!SCM_CHARP (ch)) if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
s = scm_i_string_start_writing (s); s = scm_i_string_start_writing (s);
@ -2702,15 +2701,15 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
#define FUNC_NAME s_scm_string_for_each #define FUNC_NAME s_scm_string_for_each
{ {
size_t cstart, cend; size_t cstart, cend;
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME); SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s, MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart, 3, start, cstart,
4, end, cend); 4, end, cend);
while (cstart < cend) while (cstart < cend)
{ {
proc_tramp (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); scm_call_1 (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
cstart++; cstart++;
} }
@ -2740,16 +2739,16 @@ SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0,
#define FUNC_NAME s_scm_string_for_each_index #define FUNC_NAME s_scm_string_for_each_index
{ {
size_t cstart, cend; size_t cstart, cend;
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME); SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
MY_VALIDATE_SUBSTRING_SPEC (2, s, MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart, 3, start, cstart,
4, end, cend); 4, end, cend);
while (cstart < cend) while (cstart < cend)
{ {
proc_tramp (proc, scm_from_size_t (cstart)); scm_call_1 (proc, scm_from_size_t (cstart));
cstart++; cstart++;
} }
@ -3106,15 +3105,15 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
else else
{ {
SCM ls = SCM_EOL; SCM ls = SCM_EOL;
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
char_pred, SCM_ARG2, FUNC_NAME);
idx = cstart; idx = cstart;
while (idx < cend) while (idx < cend)
{ {
SCM res, ch; SCM res, ch;
ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx)); ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
res = pred_tramp (char_pred, ch); res = scm_call_1 (char_pred, ch);
if (scm_is_true (res)) if (scm_is_true (res))
ls = scm_cons (ch, ls); ls = scm_cons (ch, ls);
idx++; idx++;
@ -3242,14 +3241,14 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
else else
{ {
SCM ls = SCM_EOL; SCM ls = SCM_EOL;
scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred); SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME); char_pred, SCM_ARG2, FUNC_NAME);
idx = cstart; idx = cstart;
while (idx < cend) while (idx < cend)
{ {
SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx)); SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
res = pred_tramp (char_pred, ch); res = scm_call_1 (char_pred, ch);
if (scm_is_false (res)) if (scm_is_false (res))
ls = scm_cons (ch, ls); ls = scm_cons (ch, ls);
idx++; idx++;