-/* Copyright (C) 1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2002 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)
*/
/* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+/* do we still need this here? */
#include "libguile/scmconfig.h"
/* AIX requires this to be the first thing in the file. The #pragma
#include "libguile/feature.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
+#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/sort.h"
return SCM_NFALSEP (SCM_SUBRF (less) (*(SCM *) a, *(SCM *) b));
} /* subr2less */
-static int
-subr2oless (SCM less, const void *a, const void *b)
-{
- return SCM_NFALSEP (SCM_SUBRF (less) (*(SCM *) a,
- *(SCM *) b,
- SCM_UNDEFINED));
-} /* subr2oless */
-
static int
lsubrless (SCM less, const void *a, const void *b)
{
scm_cons (*(SCM *) b, SCM_EOL)),
SCM_ENV (code));
/* Evaluate the closure body */
- return SCM_NFALSEP (scm_eval_body (SCM_CDR (SCM_CODE (code)), env));
+ return !SCM_FALSEP (scm_eval_body (SCM_CLOSURE_BODY (code), env));
} /* closureless */
static int
switch (SCM_TYP7 (p))
{
case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
case scm_tc7_rpsubr:
case scm_tc7_asubr:
return subr2less;
- case scm_tc7_subr_2o:
- return subr2oless;
case scm_tc7_lsubr:
return lsubrless;
case scm_tcs_closures:
size_t vlen, spos, len, size = sizeof (SCM);
SCM *vp;
- SCM_VALIDATE_VECTOR (1,vec);
- SCM_VALIDATE_NIM (2,less);
+ SCM_VALIDATE_VECTOR (1, vec);
+ SCM_VALIDATE_NIM (2, less);
- vp = SCM_VELTS (vec); /* vector pointer */
+ vp = SCM_WRITABLE_VELTS (vec); /* vector pointer */
vlen = SCM_VECTOR_LENGTH (vec);
SCM_VALIDATE_INUM_MIN_COPY (3, startpos, 0, spos);
- SCM_ASSERT_RANGE (3,startpos, spos <= vlen);
- SCM_VALIDATE_INUM_RANGE (4,endpos,0,vlen+1);
+ SCM_ASSERT_RANGE (3, startpos, spos <= vlen);
+ SCM_VALIDATE_INUM_RANGE (4, endpos,0, vlen+1);
len = SCM_INUM (endpos) - spos;
quicksort (&vp[spos], len, size, scm_cmp_function (less), less);
- return SCM_UNSPECIFIED;
+
+ return scm_return_first (SCM_UNSPECIFIED, vec);
/* return vec; */
}
#undef FUNC_NAME
{
long len, j; /* list/vector length, temp j */
SCM item, rest; /* rest of items loop variable */
- SCM *vp;
+ SCM const *vp;
cmp_fun_t cmp = scm_cmp_function (less);
- if (SCM_NULLP (items))
+ if (SCM_NULL_OR_NIL_P (items))
return SCM_BOOL_T;
- SCM_VALIDATE_NIM (2,less);
+ SCM_VALIDATE_NIM (2, less);
if (SCM_CONSP (items))
{
len = scm_ilength (items); /* also checks that it's a pure list */
- SCM_ASSERT_RANGE (1,items,len >= 0);
+ SCM_ASSERT_RANGE (1, items, len >= 0);
if (len <= 1)
return SCM_BOOL_T;
Note: this does _not_ accept vectors. */
SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
- "Takes two lists @var{alist} and @var{blist} such that\n"
- "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
- "returns a new list in which the elements of @var{alist} and\n"
+ "Merge two already sorted lists into one.\n"
+ "Given two lists @var{alist} and @var{blist}, such that\n"
+ "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
+ "return a new list in which the elements of @var{alist} and\n"
"@var{blist} have been stably interleaved so that\n"
"@code{(sorted? (merge alist blist less?) less?)}.\n"
"Note: this does _not_ accept vectors.")
long alen, blen; /* list lengths */
SCM build, last;
cmp_fun_t cmp = scm_cmp_function (less);
- SCM_VALIDATE_NIM (3,less);
+ SCM_VALIDATE_NIM (3, less);
- if (SCM_NULLP (alist))
+ if (SCM_NULL_OR_NIL_P (alist))
return blist;
- else if (SCM_NULLP (blist))
+ else if (SCM_NULL_OR_NIL_P (blist))
return alist;
else
{
- SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1,alist,alen);
- SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2,blist,blen);
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
if ((*cmp) (less, SCM_CARLOC (blist), SCM_CARLOC (alist)))
{
build = scm_cons (SCM_CAR (blist), SCM_EOL);
{
SCM build, last;
- if (SCM_NULLP (alist))
+ if (SCM_NULL_OR_NIL_P (alist))
return blist;
- else if (SCM_NULLP (blist))
+ else if (SCM_NULL_OR_NIL_P (blist))
return alist;
else
{
{
long alen, blen; /* list lengths */
- SCM_VALIDATE_NIM (3,less);
- if (SCM_NULLP (alist))
+ SCM_VALIDATE_NIM (3, less);
+ if (SCM_NULL_OR_NIL_P (alist))
return blist;
- else if (SCM_NULLP (blist))
+ else if (SCM_NULL_OR_NIL_P (blist))
return alist;
else
{
- SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1,alist,alen);
- SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2,blist,blen);
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
return scm_merge_list_x (alist, blist,
alen, blen,
scm_cmp_function (less),
#define FUNC_NAME s_scm_sort_x
{
long len; /* list/vector length */
- if (SCM_NULLP(items))
- return SCM_EOL;
+ if (SCM_NULL_OR_NIL_P (items))
+ return items;
- SCM_VALIDATE_NIM (2,less);
+ SCM_VALIDATE_NIM (2, less);
if (SCM_CONSP (items))
{
- SCM_VALIDATE_LIST_COPYLEN (1,items,len);
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
else if (SCM_VECTORP (items))
"elements. This is not a stable sort.")
#define FUNC_NAME s_scm_sort
{
- if (SCM_NULLP(items))
- return SCM_EOL;
+ if (SCM_NULL_OR_NIL_P (items))
+ return items;
- SCM_VALIDATE_NIM (2,less);
+ SCM_VALIDATE_NIM (2, less);
if (SCM_CONSP (items))
{
long len;
- SCM_VALIDATE_LIST_COPYLEN (1,items,len);
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
-#ifdef HAVE_ARRAYS
+#ifdef SCM_HAVE_ARRAYS
/* support ordinary vectors even if arrays not available? */
else if (SCM_VECTORP (items))
{
#undef FUNC_NAME
static void
-scm_merge_vector_x (void *const vecbase,
- void *const tempbase,
+scm_merge_vector_x (SCM vec,
+ SCM * temp,
cmp_fun_t cmp,
SCM less,
long low,
long mid,
long high)
{
- register SCM *vp = (SCM *) vecbase;
- register SCM *temp = (SCM *) tempbase;
long it; /* Index for temp vector */
long i1 = low; /* Index for lower vector segment */
long i2 = mid + 1; /* Index for upper vector segment */
/* Copy while both segments contain more characters */
for (it = low; (i1 <= mid) && (i2 <= high); ++it)
- if ((*cmp) (less, &vp[i2], &vp[i1]))
- temp[it] = vp[i2++];
- else
- temp[it] = vp[i1++];
-
- /* Copy while first segment contains more characters */
- while (i1 <= mid)
- temp[it++] = vp[i1++];
-
- /* Copy while second segment contains more characters */
- while (i2 <= high)
- temp[it++] = vp[i2++];
+ {
+ /*
+ Every call of LESS might invoke GC. For full correctness, we
+ should reset the generation of vecbase and tempbase between
+ every call of less.
+
+ */
+ register SCM *vp = SCM_WRITABLE_VELTS(vec);
+
+ if ((*cmp) (less, &vp[i2], &vp[i1]))
+ temp[it] = vp[i2++];
+ else
+ temp[it] = vp[i1++];
+ }
- /* Copy back from temp to vp */
- for (it = low; it <= high; ++it)
- vp[it] = temp[it];
-} /* scm_merge_vector_x */
+ {
+ register SCM *vp = SCM_WRITABLE_VELTS(vec);
+
+ /* Copy while first segment contains more characters */
+ while (i1 <= mid)
+ temp[it++] = vp[i1++];
+
+ /* Copy while second segment contains more characters */
+ while (i2 <= high)
+ temp[it++] = vp[i2++];
+
+ /* Copy back from temp to vp */
+ for (it = low; it <= high; ++it)
+ vp[it] = temp[it];
+ }
+} /* scm_merge_vector_x */
static void
-scm_merge_vector_step (void *const vp,
- void *const temp,
+scm_merge_vector_step (SCM vp,
+ SCM * temp,
cmp_fun_t cmp,
SCM less,
long low,
{
long len; /* list/vector length */
- if (SCM_NULLP (items))
- return SCM_EOL;
+ if (SCM_NULL_OR_NIL_P (items))
+ return items;
- SCM_VALIDATE_NIM (2,less);
+ SCM_VALIDATE_NIM (2, less);
if (SCM_CONSP (items))
{
- SCM_VALIDATE_LIST_COPYLEN (1,items,len);
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
else if (SCM_VECTORP (items))
{
- SCM *temp, *vp;
+ SCM *temp;
len = SCM_VECTOR_LENGTH (items);
- temp = malloc (len * sizeof(SCM));
- vp = SCM_VELTS (items);
- scm_merge_vector_step (vp,
+
+ /*
+ the following array does not contain any new references to
+ SCM objects, so we can get away with allocing it on the heap.
+ */
+ temp = scm_malloc (len * sizeof(SCM));
+
+ scm_merge_vector_step (items,
temp,
scm_cmp_function (less),
less,
#undef FUNC_NAME
/* stable_sort manages lists and vectors */
-
SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort
{
- long len; /* list/vector length */
- if (SCM_NULLP (items))
- return SCM_EOL;
- SCM_VALIDATE_NIM (2,less);
+ if (SCM_NULL_OR_NIL_P (items))
+ return items;
+
+ SCM_VALIDATE_NIM (2, less);
if (SCM_CONSP (items))
{
- SCM_VALIDATE_LIST_COPYLEN (1,items,len);
+ long len; /* list/vector length */
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
-#ifdef HAVE_ARRAYS
+#ifdef SCM_HAVE_ARRAYS
/* support ordinary vectors even if arrays not available? */
else if (SCM_VECTORP (items))
{
- SCM retvec;
- SCM *temp, *vp;
- len = SCM_VECTOR_LENGTH (items);
- retvec = scm_make_uve (len, scm_array_prototype (items));
+ long len = SCM_VECTOR_LENGTH (items);
+ SCM *temp = scm_malloc (len * sizeof (SCM));
+ SCM retvec = scm_make_uve (len, scm_array_prototype (items));
scm_array_copy_x (items, retvec);
- temp = malloc (len * sizeof (SCM));
- vp = SCM_VELTS (retvec);
- scm_merge_vector_step (vp,
+
+ scm_merge_vector_step (retvec,
temp,
scm_cmp_function (less),
less,
#define FUNC_NAME s_scm_sort_list_x
{
long len;
- SCM_VALIDATE_LIST_COPYLEN (1,items,len);
- SCM_VALIDATE_NIM (2,less);
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ SCM_VALIDATE_NIM (2, less);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_sort_list
{
long len;
- SCM_VALIDATE_LIST_COPYLEN (1,items,len);
- SCM_VALIDATE_NIM (2,less);
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ SCM_VALIDATE_NIM (2, less);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
void
scm_init_sort ()
{
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/sort.x"
-#endif
scm_add_feature ("sort");
}
HCoop / bpt / guile.git / blobdiff