-/* Copyright (C) 1999 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001 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)
* 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 */
/* Written in December 1998 by Roland Orre <orre@nada.kth.se>
# endif
#endif
+#include <string.h>
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/ramap.h"
#include "libguile/alist.h"
#include "libguile/feature.h"
+#include "libguile/root.h"
#include "libguile/vectors.h"
+#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/sort.h"
static int
closureless (SCM code, const void *a, const void *b)
{
- SCM env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
+ SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
scm_cons (*(SCM *) a,
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
applyless (SCM less, const void *a, const void *b)
{
- return SCM_NFALSEP (scm_apply (less,
- scm_cons (*(SCM *) a,
- scm_cons (*(SCM *) b, SCM_EOL)),
- SCM_EOL));
+ return SCM_NFALSEP (scm_call_2 (less, *(SCM *) a, *(SCM *) b));
} /* applyless */
static cmp_fun_t
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
-"")
+ "Sort the vector @var{vec}, using @var{less} for comparing\n"
+ "the vector elements. @var{startpos} and @var{endpos} delimit\n"
+ "the range of the vector which gets sorted. The return value\n"
+ "is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
size_t vlen, spos, len, size = sizeof (SCM);
SCM *vp;
- SCM_VALIDATE_NIM (1,vec);
- SCM_VALIDATE_NIM (2,less);
- switch (SCM_TYP7 (vec))
- {
- case scm_tc7_vector: /* the only type we manage is vector */
- break;
-#if 0 /* HAVE_ARRAYS */
- case scm_tc7_ivect: /* long */
- case scm_tc7_uvect: /* unsigned */
- case scm_tc7_fvect: /* float */
- case scm_tc7_dvect: /* double */
-#endif
- default:
- SCM_WTA (1,vec);
- }
- vp = SCM_VELTS (vec); /* vector pointer */
- vlen = SCM_LENGTH (vec);
+ SCM_VALIDATE_VECTOR (1, vec);
+ SCM_VALIDATE_NIM (2, less);
+
+ vp = SCM_WRITABLE_VELTS (vec); /* vector pointer */
+ vlen = SCM_VECTOR_LENGTH (vec);
- SCM_VALIDATE_INUM_COPY (3,startpos,spos);
- SCM_ASSERT_RANGE (3,startpos,(spos >= 0) && (spos <= vlen));
- SCM_VALIDATE_INUM_RANGE (4,endpos,0,vlen+1);
+ 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);
len = SCM_INUM (endpos) - spos;
quicksort (&vp[spos], len, size, scm_cmp_function (less), less);
+ SCM_GC_FLAG_OBJECT_WRITE(vec);
+
return SCM_UNSPECIFIED;
/* return vec; */
}
* (not (less? (list-ref list i) (list-ref list (- i 1)))). */
SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
(SCM items, SCM less),
-"")
+ "Return @code{#t} iff @var{items} is a list or a vector such that\n"
+ "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
+ "applied to all elements i - 1 and i")
#define FUNC_NAME s_scm_sorted_p
{
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 (1,items);
- 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;
j = len - 1;
while (j > 0)
{
- if ((*cmp) (less, &SCM_CAR(rest), &item))
+ if ((*cmp) (less, SCM_CARLOC(rest), &item))
return SCM_BOOL_F;
else
{
}
else
{
- switch (SCM_TYP7 (items))
+ SCM_VALIDATE_VECTOR (1, items);
+
+ vp = SCM_VELTS (items); /* vector pointer */
+ len = SCM_VECTOR_LENGTH (items);
+ j = len - 1;
+ while (j > 0)
{
- case scm_tc7_vector:
- {
- vp = SCM_VELTS (items); /* vector pointer */
- len = SCM_LENGTH (items);
- j = len - 1;
- while (j > 0)
- {
- if ((*cmp) (less, &vp[1], vp))
- return SCM_BOOL_F;
- else
- {
- vp++;
- j--;
- }
- }
- return SCM_BOOL_T;
- }
- break;
-#if 0 /* HAVE_ARRAYS */
- case scm_tc7_ivect: /* long */
- case scm_tc7_uvect: /* unsigned */
- case scm_tc7_fvect: /* float */
- case scm_tc7_dvect: /* double */
-#endif
- default:
- SCM_WTA (1,items);
+ if ((*cmp) (less, &vp[1], vp))
+ return SCM_BOOL_F;
+ else
+ {
+ vp++;
+ j--;
+ }
}
+ return SCM_BOOL_T;
}
+
return SCM_BOOL_F;
}
#undef FUNC_NAME
Note: this does _not_ accept vectors. */
SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
-"")
+ "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.")
#define FUNC_NAME s_scm_merge
{
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);
- if ((*cmp) (less, &SCM_CAR (blist), &SCM_CAR (alist)))
+ 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);
blist = SCM_CDR (blist);
last = build;
while ((alen > 0) && (blen > 0))
{
- if ((*cmp) (less, &SCM_CAR (blist), &SCM_CAR (alist)))
+ if ((*cmp) (less, SCM_CARLOC (blist), SCM_CARLOC (alist)))
{
SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL));
blist = SCM_CDR (blist);
{
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
{
- if ((*cmp) (less, &SCM_CAR (blist), &SCM_CAR (alist)))
+ if ((*cmp) (less, SCM_CARLOC (blist), SCM_CARLOC (alist)))
{
build = blist;
blist = SCM_CDR (blist);
last = build;
while ((alen > 0) && (blen > 0))
{
- if ((*cmp) (less, &SCM_CAR (blist), &SCM_CAR (alist)))
+ if ((*cmp) (less, SCM_CARLOC (blist), SCM_CARLOC (alist)))
{
SCM_SETCDR (last, blist);
blist = SCM_CDR (blist);
SCM_DEFINE (scm_merge_x, "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"
+ "@var{blist} have been stably interleaved so that\n"
+ " @code{(sorted? (merge alist blist less?) less?)}.\n"
+ "This is the destructive variant of @code{merge}\n"
+ "Note: this does _not_ accept vectors.")
#define FUNC_NAME s_scm_merge_x
{
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),
scm_merge_list_step (SCM * seq,
cmp_fun_t cmp,
SCM less,
- int n)
+ long n)
{
SCM a, b;
SCM_SETCDR (rest, SCM_EOL);
if ((*cmp) (less, &y, &x))
{
- SCM_CAR (p) = y;
- SCM_CAR (rest) = x;
+ SCM_SETCAR (p, y);
+ SCM_SETCAR (rest, x);
}
return p;
}
/* scm_sort_x manages lists and vectors, not stable sort */
SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
(SCM items, SCM less),
-"")
+ "Sort the sequence @var{items}, which may be a list or a\n"
+ "vector. @var{less} is used for comparing the sequence\n"
+ "elements. The sorting is destructive, that means that the\n"
+ "input sequence is modified to produce the sorted result.\n"
+ "This is not a stable sort.")
#define FUNC_NAME s_scm_sort_x
{
long len; /* list/vector length */
- if (SCM_NULLP(items))
- return SCM_EOL;
- SCM_VALIDATE_NIM (1,items);
- 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);
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
else if (SCM_VECTORP (items))
{
- len = SCM_LENGTH (items);
+ len = SCM_VECTOR_LENGTH (items);
scm_restricted_vector_sort_x (items,
less,
SCM_MAKINUM (0L),
return items;
}
else
- RETURN_SCM_WTA (1,items);
+ SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
(SCM items, SCM less),
-"")
+ "Sort the sequence @var{items}, which may be a list or a\n"
+ "vector. @var{less} is used for comparing the sequence\n"
+ "elements. This is not a stable sort.")
#define FUNC_NAME s_scm_sort
{
- SCM sortvec; /* the vector we actually sort */
- long len; /* list/vector length */
- if (SCM_NULLP(items))
- return SCM_EOL;
- SCM_VALIDATE_NIM (1,items);
- 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;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
/* support ordinary vectors even if arrays not available? */
else if (SCM_VECTORP (items))
{
- len = SCM_LENGTH (items);
- sortvec = scm_make_uve (len, scm_array_prototype (items));
+ long len = SCM_VECTOR_LENGTH (items);
+ SCM sortvec = scm_make_uve (len, scm_array_prototype (items));
+
scm_array_copy_x (items, sortvec);
scm_restricted_vector_sort_x (sortvec,
less,
}
#endif
else
- RETURN_SCM_WTA (1,items);
+ SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
(SCM items, SCM less),
-"")
+ "Sort the sequence @var{items}, which may be a list or a\n"
+ "vector. @var{less} is used for comparing the sequence elements.\n"
+ "The sorting is destructive, that means that the input sequence\n"
+ "is modified to produce the sorted result.\n"
+ "This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort_x
{
long len; /* list/vector length */
- if (SCM_NULLP (items))
- return SCM_EOL;
- SCM_VALIDATE_NIM (1,items);
- 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);
+ 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;
- len = SCM_LENGTH (items);
+ len = SCM_VECTOR_LENGTH (items);
temp = malloc (len * sizeof(SCM));
- vp = SCM_VELTS (items);
+
+
+ vp = SCM_WRITABLE_VELTS (items);
+ /*
+ This routine modifies VP
+ */
+
+ SCM_GC_FLAG_OBJECT_WRITE(items);
scm_merge_vector_step (vp,
temp,
scm_cmp_function (less),
return items;
}
else
- RETURN_SCM_WTA (1,items);
+ SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
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"
+ "vector. @var{less} is used for comparing the sequence elements.\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 (1,items);
- 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);
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
{
SCM retvec;
SCM *temp, *vp;
- len = SCM_LENGTH (items);
+ len = SCM_VECTOR_LENGTH (items);
retvec = scm_make_uve (len, scm_array_prototype (items));
scm_array_copy_x (items, retvec);
temp = malloc (len * sizeof (SCM));
- vp = SCM_VELTS (retvec);
+
+ /*
+ don't worry about write barrier: retvec is new anyway.
+ */
+ vp = SCM_WRITABLE_VELTS (retvec);
+
scm_merge_vector_step (vp,
temp,
scm_cmp_function (less),
}
#endif
else
- RETURN_SCM_WTA (1,items);
+ SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
/* stable */
SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
(SCM items, SCM less),
-"")
+ "Sort the list @var{items}, using @var{less} for comparing the\n"
+ "list elements. The sorting is destructive, that means that the\n"
+ "input list is modified to produce the sorted result.\n"
+ "This is a stable sort.")
#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
/* stable */
SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
- (SCM items, SCM less),
-"")
+ (SCM items, SCM less),
+ "Sort the list @var{items}, using @var{less} for comparing the\n"
+ "list elements. This is a stable sort.")
#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);
}
HCoop / bpt / guile.git / blobdiff