mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-17 01:00:20 +02:00
Merge until e0bcda4ad9 from stable-2.2
This commit is contained in:
Andy Wingo
commit
f85d3c0bd8
21 changed files with 507 additions and 312 deletions
|
|
@ -149,8 +149,10 @@ initialize_vector_handle (scm_t_array_handle *h, size_t len,
|
|||
h->dim0.ubnd = (ssize_t) (len - 1U);
|
||||
h->dim0.inc = 1;
|
||||
h->element_type = element_type;
|
||||
h->elements = elements;
|
||||
h->writable_elements = mutable_p ? ((void *) elements) : NULL;
|
||||
/* elements != writable_elements is used to check mutability later on.
|
||||
Ignore it if the array is empty. */
|
||||
h->elements = len==0 ? NULL : elements;
|
||||
h->writable_elements = mutable_p ? ((void *) h->elements) : NULL;
|
||||
h->vector = h->array;
|
||||
h->vref = vref;
|
||||
h->vset = vset;
|
||||
|
|
|
|||
|
|
@ -263,7 +263,7 @@ racp (SCM src, SCM dst)
|
|||
{
|
||||
SCM const * el_s = h_s.elements;
|
||||
SCM * el_d = h_d.writable_elements;
|
||||
if (!el_d)
|
||||
if (!el_d && n>0)
|
||||
scm_wrong_type_arg_msg ("array-copy!", SCM_ARG2, dst, "mutable array");
|
||||
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
|
||||
el_d[i_d] = el_s[i_s];
|
||||
|
|
@ -679,6 +679,7 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
|
|||
"@end lisp")
|
||||
#define FUNC_NAME s_scm_array_slice_for_each
|
||||
{
|
||||
SCM xargs = args;
|
||||
int const N = scm_ilength (args);
|
||||
int const frank = scm_to_int (frame_rank);
|
||||
int ocd;
|
||||
|
|
@ -742,9 +743,9 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
|
|||
assert((pool0+pool_size==pool) && "internal error");
|
||||
#undef AFIC_ALLOC_ADVANCE
|
||||
|
||||
for (n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
|
||||
for (n=0, xargs=args; scm_is_pair(xargs); xargs=scm_cdr(xargs), ++n)
|
||||
{
|
||||
args_[n] = scm_car(args);
|
||||
args_[n] = scm_car(xargs);
|
||||
scm_array_get_handle(args_[n], ah+n);
|
||||
as[n] = scm_array_handle_dims(ah+n);
|
||||
rank[n] = scm_array_handle_rank(ah+n);
|
||||
|
|
@ -752,29 +753,24 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
|
|||
/* checks */
|
||||
msg = NULL;
|
||||
if (frank<0)
|
||||
msg = "bad frame rank";
|
||||
msg = "bad frame rank ~S, ~S";
|
||||
else
|
||||
{
|
||||
for (n=0; n!=N; ++n)
|
||||
{
|
||||
if (rank[n]<frank)
|
||||
{
|
||||
msg = "frame too large for arguments";
|
||||
msg = "frame too large for arguments: ~S, ~S";
|
||||
goto check_msg;
|
||||
}
|
||||
for (k=0; k!=frank; ++k)
|
||||
{
|
||||
if (as[n][k].lbnd!=0)
|
||||
if (as[0][k].lbnd!=as[n][k].lbnd || as[0][k].ubnd!=as[n][k].ubnd)
|
||||
{
|
||||
msg = "non-zero base index is not supported";
|
||||
msg = "mismatched frames: ~S, ~S";
|
||||
goto check_msg;
|
||||
}
|
||||
if (as[0][k].ubnd!=as[n][k].ubnd)
|
||||
{
|
||||
msg = "mismatched frames";
|
||||
goto check_msg;
|
||||
}
|
||||
s[k] = as[n][k].ubnd + 1;
|
||||
s[k] = as[n][k].ubnd - as[n][k].lbnd + 1;
|
||||
|
||||
/* this check is needed if the array cannot be entirely */
|
||||
/* unrolled, because the unrolled subloop will be run before */
|
||||
|
|
@ -789,7 +785,7 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
|
|||
{
|
||||
for (n=0; n!=N; ++n)
|
||||
scm_array_handle_release(ah+n);
|
||||
scm_misc_error("array-slice-for-each", msg, scm_cons_star(frame_rank, args));
|
||||
scm_misc_error("array-slice-for-each", msg, scm_cons(frame_rank, args));
|
||||
}
|
||||
/* prepare moving cells. */
|
||||
for (n=0; n!=N; ++n)
|
||||
|
|
|
|||
|
|
@ -908,50 +908,17 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
|
|||
return 1;
|
||||
}
|
||||
|
||||
/* Print an array.
|
||||
*/
|
||||
|
||||
int
|
||||
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
|
||||
{
|
||||
scm_t_array_handle h;
|
||||
size_t i;
|
||||
int print_lbnds = 0, zero_size = 0, print_lens = 0;
|
||||
int d;
|
||||
|
||||
scm_call_2 (scm_c_private_ref ("ice-9 arrays", "array-print-prefix"),
|
||||
array, port);
|
||||
|
||||
scm_array_get_handle (array, &h);
|
||||
|
||||
scm_putc ('#', port);
|
||||
if (SCM_I_ARRAYP (array))
|
||||
scm_intprint (h.ndims, 10, port);
|
||||
if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
|
||||
scm_write (scm_array_handle_element_type (&h), port);
|
||||
|
||||
for (i = 0; i < h.ndims; i++)
|
||||
{
|
||||
if (h.dims[i].lbnd != 0)
|
||||
print_lbnds = 1;
|
||||
if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
|
||||
zero_size = 1;
|
||||
else if (zero_size)
|
||||
print_lens = 1;
|
||||
}
|
||||
|
||||
if (print_lbnds || print_lens)
|
||||
for (i = 0; i < h.ndims; i++)
|
||||
{
|
||||
if (print_lbnds)
|
||||
{
|
||||
scm_putc ('@', port);
|
||||
scm_intprint (h.dims[i].lbnd, 10, port);
|
||||
}
|
||||
if (print_lens)
|
||||
{
|
||||
scm_putc (':', port);
|
||||
scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
|
||||
10, port);
|
||||
}
|
||||
}
|
||||
|
||||
if (h.ndims == 0)
|
||||
{
|
||||
/* Rank zero arrays, which are really just scalars, are printed
|
||||
|
|
@ -977,10 +944,13 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
|
|||
scm_putc ('(', port);
|
||||
scm_i_print_array_dimension (&h, 0, 0, port, pstate);
|
||||
scm_putc (')', port);
|
||||
return 1;
|
||||
d = 1;
|
||||
}
|
||||
else
|
||||
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
|
||||
d = scm_i_print_array_dimension (&h, 0, 0, port, pstate);
|
||||
|
||||
scm_array_handle_release (&h);
|
||||
return d;
|
||||
}
|
||||
|
||||
void
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
|
||||
* 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
|
||||
* 2014, 2015 Free Software Foundation, Inc.
|
||||
* 2014, 2015, 2017 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -467,8 +467,6 @@ fport_input_waiting (SCM port)
|
|||
|
||||
#define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
|
||||
|
||||
static SCM revealed_ports = SCM_EOL;
|
||||
static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
|
||||
|
||||
/* Find a port in the table and return its revealed count.
|
||||
Also used by the garbage collector.
|
||||
|
|
@ -476,13 +474,7 @@ static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
|
|||
int
|
||||
scm_revealed_count (SCM port)
|
||||
{
|
||||
int ret;
|
||||
|
||||
scm_i_pthread_mutex_lock (&revealed_lock);
|
||||
ret = SCM_REVEALED (port);
|
||||
scm_i_pthread_mutex_unlock (&revealed_lock);
|
||||
|
||||
return ret;
|
||||
return SCM_REVEALED (port);
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
|
||||
|
|
@ -503,25 +495,14 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
|
|||
"The return value is unspecified.")
|
||||
#define FUNC_NAME s_scm_set_port_revealed_x
|
||||
{
|
||||
int r, prev;
|
||||
int r;
|
||||
|
||||
port = SCM_COERCE_OUTPORT (port);
|
||||
SCM_VALIDATE_OPFPORT (1, port);
|
||||
|
||||
r = scm_to_int (rcount);
|
||||
|
||||
scm_i_pthread_mutex_lock (&revealed_lock);
|
||||
|
||||
prev = SCM_REVEALED (port);
|
||||
SCM_REVEALED (port) = r;
|
||||
|
||||
if (r && !prev)
|
||||
revealed_ports = scm_cons (port, revealed_ports);
|
||||
else if (prev && !r)
|
||||
revealed_ports = scm_delq_x (port, revealed_ports);
|
||||
|
||||
scm_i_pthread_mutex_unlock (&revealed_lock);
|
||||
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -539,18 +520,7 @@ SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
|
|||
SCM_VALIDATE_OPFPORT (1, port);
|
||||
|
||||
a = scm_to_int (addend);
|
||||
if (!a)
|
||||
return SCM_UNSPECIFIED;
|
||||
|
||||
scm_i_pthread_mutex_lock (&revealed_lock);
|
||||
|
||||
SCM_REVEALED (port) += a;
|
||||
if (SCM_REVEALED (port) == a)
|
||||
revealed_ports = scm_cons (port, revealed_ports);
|
||||
else if (!SCM_REVEALED (port))
|
||||
revealed_ports = scm_delq_x (port, revealed_ports);
|
||||
|
||||
scm_i_pthread_mutex_unlock (&revealed_lock);
|
||||
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
|
@ -668,6 +638,11 @@ fport_close (SCM port)
|
|||
{
|
||||
scm_t_fport *fp = SCM_FSTREAM (port);
|
||||
|
||||
if (SCM_REVEALED (port) > 0)
|
||||
/* The port has a non-zero revealed count, so don't close the
|
||||
underlying file descriptor. */
|
||||
return;
|
||||
|
||||
scm_run_fdes_finalizers (fp->fdes);
|
||||
if (close (fp->fdes) != 0)
|
||||
/* It's not useful to retry after EINTR, as the file descriptor is
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
#ifndef SCM_FPORTS_H
|
||||
#define SCM_FPORTS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995-2001, 2006, 2008, 2009, 2011, 2012,
|
||||
* 2017 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -33,9 +34,8 @@
|
|||
typedef struct scm_t_fport {
|
||||
/* The file descriptor. */
|
||||
int fdes;
|
||||
/* Revealed count; 0 indicates not revealed, > 1 revealed. Revealed
|
||||
ports do not get garbage-collected. */
|
||||
int revealed;
|
||||
/* Revealed count; 0 indicates not revealed, > 1 revealed. */
|
||||
unsigned int revealed;
|
||||
/* Set of scm_fport_option flags. */
|
||||
unsigned options;
|
||||
} scm_t_fport;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1995-2001, 2003-2004, 2006-2016
|
||||
/* Copyright (C) 1995-2001, 2003-2004, 2006-2017
|
||||
* Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
|
|
@ -680,10 +680,12 @@ SCM scm_i_port_weak_set;
|
|||
|
||||
/* Port finalization. */
|
||||
|
||||
static SCM close_port (SCM, int);
|
||||
|
||||
static SCM
|
||||
do_close (void *data)
|
||||
{
|
||||
return scm_close_port (SCM_PACK_POINTER (data));
|
||||
return close_port (SCM_PACK_POINTER (data), 0);
|
||||
}
|
||||
|
||||
/* Finalize the object (a port) pointed to by PTR. */
|
||||
|
|
@ -859,6 +861,33 @@ SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
|
|||
|
||||
/* Closing ports. */
|
||||
|
||||
/* Close PORT. If EXPLICIT is true, then we are explicitly closing PORT
|
||||
with 'close-port'; otherwise PORT is just being GC'd. */
|
||||
static SCM
|
||||
close_port (SCM port, int explicit)
|
||||
{
|
||||
if (SCM_CLOSEDP (port))
|
||||
return SCM_BOOL_F;
|
||||
|
||||
/* May throw an exception. */
|
||||
if (SCM_OUTPUT_PORT_P (port))
|
||||
scm_flush (port);
|
||||
|
||||
if (explicit && SCM_FPORTP (port))
|
||||
/* We're closing PORT explicitly so clear its revealed count so that
|
||||
it really gets closed. */
|
||||
SCM_FSTREAM (port)->revealed = 0;
|
||||
|
||||
SCM_CLR_PORT_OPEN_FLAG (port);
|
||||
|
||||
if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC)
|
||||
scm_weak_set_remove_x (scm_i_port_weak_set, port);
|
||||
|
||||
release_port (port);
|
||||
|
||||
return SCM_BOOL_T;
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
|
||||
(SCM port),
|
||||
"Close the specified port object. Return @code{#t} if it\n"
|
||||
|
|
@ -872,21 +901,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
|
|||
port = SCM_COERCE_OUTPORT (port);
|
||||
SCM_VALIDATE_PORT (1, port);
|
||||
|
||||
if (SCM_CLOSEDP (port))
|
||||
return SCM_BOOL_F;
|
||||
|
||||
/* May throw an exception. */
|
||||
if (SCM_OUTPUT_PORT_P (port))
|
||||
scm_flush (port);
|
||||
|
||||
SCM_CLR_PORT_OPEN_FLAG (port);
|
||||
|
||||
if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC)
|
||||
scm_weak_set_remove_x (scm_i_port_weak_set, port);
|
||||
|
||||
release_port (port);
|
||||
|
||||
return SCM_BOOL_T;
|
||||
return close_port (port, 1);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
reduces the probability of selecting a bad pivot value and eliminates
|
||||
certain extraneous comparisons.
|
||||
|
||||
3. Only quicksorts NR_ELEMS / MAX_THRESH partitions, leaving insertion sort
|
||||
3. Only quicksorts (UBND-LBND+1) / MAX_THRESH partitions, leaving insertion sort
|
||||
to order the MAX_THRESH items within each partition. This is a big win,
|
||||
since insertion sort is faster for small, mostly sorted array segments.
|
||||
|
||||
|
|
@ -54,33 +54,29 @@
|
|||
#define STACK_NOT_EMPTY (stack < top)
|
||||
|
||||
static void
|
||||
NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
|
||||
NAME (VEC_PARAM ssize_t lbnd, ssize_t ubnd, INC_PARAM SCM less)
|
||||
{
|
||||
/* Stack node declarations used to store unfulfilled partition obligations. */
|
||||
typedef struct {
|
||||
size_t lo;
|
||||
size_t hi;
|
||||
ssize_t lo;
|
||||
ssize_t hi;
|
||||
} stack_node;
|
||||
|
||||
static const char s_buggy_less[] = "buggy less predicate used when sorting";
|
||||
|
||||
if (nr_elems == 0)
|
||||
/* Avoid lossage with unsigned arithmetic below. */
|
||||
return;
|
||||
|
||||
if (nr_elems > MAX_THRESH)
|
||||
if (ubnd-lbnd+1 > MAX_THRESH)
|
||||
{
|
||||
size_t lo = 0;
|
||||
size_t hi = nr_elems-1;
|
||||
ssize_t lo = lbnd;
|
||||
ssize_t hi = ubnd;
|
||||
|
||||
stack_node stack[STACK_SIZE];
|
||||
stack_node *top = stack + 1;
|
||||
|
||||
while (STACK_NOT_EMPTY)
|
||||
{
|
||||
size_t left;
|
||||
size_t right;
|
||||
size_t mid = lo + (hi - lo) / 2;
|
||||
ssize_t left;
|
||||
ssize_t right;
|
||||
ssize_t mid = lo + (hi - lo) / 2;
|
||||
SCM pivot;
|
||||
|
||||
/* Select median value from among LO, MID, and HI. Rearrange
|
||||
|
|
@ -145,16 +141,16 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
|
|||
ignore one or both. Otherwise, push the larger partition's
|
||||
bounds on the stack and continue sorting the smaller one. */
|
||||
|
||||
if ((size_t) (right - lo) <= MAX_THRESH)
|
||||
if ((right - lo) <= MAX_THRESH)
|
||||
{
|
||||
if ((size_t) (hi - left) <= MAX_THRESH)
|
||||
if ((hi - left) <= MAX_THRESH)
|
||||
/* Ignore both small partitions. */
|
||||
POP (lo, hi);
|
||||
else
|
||||
/* Ignore small left partition. */
|
||||
lo = left;
|
||||
}
|
||||
else if ((size_t) (hi - left) <= MAX_THRESH)
|
||||
else if ((hi - left) <= MAX_THRESH)
|
||||
/* Ignore small right partition. */
|
||||
hi = right;
|
||||
else if ((right - lo) > (hi - left))
|
||||
|
|
@ -179,10 +175,10 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
|
|||
one beyond it!). */
|
||||
|
||||
{
|
||||
size_t tmp = 0;
|
||||
size_t end = nr_elems-1;
|
||||
size_t thresh = min (end, MAX_THRESH);
|
||||
size_t run;
|
||||
ssize_t tmp = lbnd;
|
||||
ssize_t end = ubnd;
|
||||
ssize_t thresh = min (end, MAX_THRESH);
|
||||
ssize_t run;
|
||||
|
||||
/* Find smallest element in first threshold and place it at the
|
||||
array's beginning. This is the smallest array element,
|
||||
|
|
@ -192,12 +188,12 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
|
|||
if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
|
||||
tmp = run;
|
||||
|
||||
if (tmp != 0)
|
||||
SWAP (tmp, 0);
|
||||
if (tmp != lbnd)
|
||||
SWAP (tmp, lbnd);
|
||||
|
||||
/* Insertion sort, running from left-hand-side up to right-hand-side. */
|
||||
|
||||
run = 1;
|
||||
run = lbnd + 1;
|
||||
while (++run <= end)
|
||||
{
|
||||
SCM_TICK;
|
||||
|
|
@ -206,7 +202,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
|
|||
while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
|
||||
{
|
||||
/* The comparison predicate may be buggy */
|
||||
if (tmp == 0)
|
||||
if (tmp == lbnd)
|
||||
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
|
||||
|
||||
tmp -= 1;
|
||||
|
|
@ -216,7 +212,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
|
|||
if (tmp != run)
|
||||
{
|
||||
SCM to_insert = GET(run);
|
||||
size_t hi, lo;
|
||||
ssize_t hi, lo;
|
||||
|
||||
for (hi = lo = run; --lo >= tmp; hi = lo)
|
||||
SET(hi, GET(lo));
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@
|
|||
#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val)
|
||||
#include "libguile/quicksort.i.c"
|
||||
|
||||
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),
|
||||
"Sort the vector @var{vec}, using @var{less} for comparing\n"
|
||||
"the vector elements. @var{startpos} (inclusively) and\n"
|
||||
|
|
@ -79,7 +79,7 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
|
|||
#define FUNC_NAME s_scm_restricted_vector_sort_x
|
||||
{
|
||||
ssize_t spos = scm_to_ssize_t (startpos);
|
||||
size_t epos = scm_to_ssize_t (endpos);
|
||||
ssize_t epos = scm_to_ssize_t (endpos)-1;
|
||||
|
||||
scm_t_array_handle handle;
|
||||
scm_t_array_dim const * dims;
|
||||
|
|
@ -89,26 +89,25 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
|
|||
if (scm_array_handle_rank(&handle) != 1)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL);
|
||||
scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (vec));
|
||||
}
|
||||
if (spos < dims[0].lbnd)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range",
|
||||
vec, scm_list_1(startpos));
|
||||
scm_error (scm_out_of_range_key, FUNC_NAME, "startpos ~s out of range of ~s",
|
||||
scm_list_2 (startpos, vec), scm_list_1 (startpos));
|
||||
}
|
||||
if (epos > dims[0].ubnd+1)
|
||||
if (epos > dims[0].ubnd)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
|
||||
vec, scm_list_1(endpos));
|
||||
scm_error (scm_out_of_range_key, FUNC_NAME, "endpos ~s out of range of ~s",
|
||||
scm_list_2 (endpos, vec), scm_list_1 (endpos));
|
||||
}
|
||||
|
||||
if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
|
||||
quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc,
|
||||
epos-spos, dims[0].inc, less);
|
||||
quicksort (scm_array_handle_writable_elements (&handle) - dims[0].lbnd * dims[0].inc,
|
||||
spos, epos, dims[0].inc, less);
|
||||
else
|
||||
quicksorta (&handle, epos-spos, less);
|
||||
quicksorta (&handle, spos, epos, less);
|
||||
|
||||
scm_array_handle_release (&handle);
|
||||
return SCM_UNSPECIFIED;
|
||||
|
|
@ -187,11 +186,11 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
|
|||
}
|
||||
else
|
||||
{
|
||||
for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i)
|
||||
for (i = 1, end = dims[0].ubnd-dims[0].lbnd+1; i < end; ++i)
|
||||
{
|
||||
if (scm_is_true (scm_call_2 (less,
|
||||
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)),
|
||||
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1)))))
|
||||
scm_array_handle_ref (&handle, i*dims[0].inc),
|
||||
scm_array_handle_ref (&handle, (i-1)*dims[0].inc))))
|
||||
{
|
||||
result = SCM_BOOL_F;
|
||||
break;
|
||||
|
|
@ -211,7 +210,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
|
|||
and returns a new list in which the elements of a and b have been stably
|
||||
interleaved so that (sorted? (merge a b less?) less?).
|
||||
Note: this does _not_ accept vectors. */
|
||||
SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
|
||||
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"
|
||||
|
|
@ -275,7 +274,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
static SCM
|
||||
static SCM
|
||||
scm_merge_list_x (SCM alist, SCM blist,
|
||||
long alen, long blen,
|
||||
SCM less)
|
||||
|
|
@ -327,7 +326,7 @@ scm_merge_list_x (SCM alist, SCM blist,
|
|||
} /* scm_merge_list_x */
|
||||
|
||||
|
||||
SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
|
||||
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"
|
||||
|
|
@ -358,7 +357,7 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
|
|||
scsh's merge-sort but that algorithm showed to not be stable, even
|
||||
though it claimed to be.
|
||||
*/
|
||||
static SCM
|
||||
static SCM
|
||||
scm_merge_list_step (SCM * seq, SCM less, long n)
|
||||
{
|
||||
SCM a, b;
|
||||
|
|
@ -406,7 +405,7 @@ scm_merge_list_step (SCM * seq, SCM less, long n)
|
|||
} while (0)
|
||||
|
||||
|
||||
SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
|
||||
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"
|
||||
|
|
@ -427,10 +426,23 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
|
|||
}
|
||||
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
|
||||
{
|
||||
scm_t_array_handle handle;
|
||||
scm_t_array_dim const * dims;
|
||||
scm_array_get_handle (items, &handle);
|
||||
dims = scm_array_handle_dims (&handle);
|
||||
|
||||
if (scm_array_handle_rank (&handle) != 1)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (items));
|
||||
}
|
||||
|
||||
scm_restricted_vector_sort_x (items,
|
||||
less,
|
||||
scm_from_int (0),
|
||||
scm_array_length (items));
|
||||
scm_from_ssize_t (dims[0].lbnd),
|
||||
scm_from_ssize_t (dims[0].ubnd+1));
|
||||
|
||||
scm_array_handle_release (&handle);
|
||||
return items;
|
||||
}
|
||||
else
|
||||
|
|
@ -439,7 +451,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
|
||||
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"
|
||||
|
|
@ -525,7 +537,7 @@ scm_merge_vector_step (SCM *vec,
|
|||
} /* scm_merge_vector_step */
|
||||
|
||||
|
||||
SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
|
||||
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"
|
||||
|
|
@ -551,7 +563,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
|
|||
SCM temp, *temp_elts, *vec_elts;
|
||||
size_t len;
|
||||
ssize_t inc;
|
||||
|
||||
|
||||
vec_elts = scm_vector_writable_elements (items, &vec_handle,
|
||||
&len, &inc);
|
||||
if (len == 0)
|
||||
|
|
@ -559,7 +571,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
|
|||
scm_array_handle_release (&vec_handle);
|
||||
return items;
|
||||
}
|
||||
|
||||
|
||||
temp = scm_c_make_vector (len, SCM_UNDEFINED);
|
||||
temp_elts = scm_vector_writable_elements (temp, &temp_handle,
|
||||
NULL, NULL);
|
||||
|
|
@ -577,7 +589,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
|
||||
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"
|
||||
|
|
@ -613,7 +625,7 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
|
||||
SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
|
||||
(SCM items, SCM less),
|
||||
"Sort the list @var{items}, using @var{less} for comparing the\n"
|
||||
"list elements. This is a stable sort.")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue