← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/sort.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libguile/sort.c
 
1
/* Copyright (C) 1999,2000,2001,2002, 2004, 2006 Free Software Foundation, Inc.
 
2
 * This library is free software; you can redistribute it and/or
 
3
 * modify it under the terms of the GNU Lesser General Public
 
4
 * License as published by the Free Software Foundation; either
 
5
 * version 2.1 of the License, or (at your option) any later version.
 
6
 *
 
7
 * This library is distributed in the hope that it will be useful,
 
8
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 
9
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
10
 * Lesser General Public License for more details.
 
11
 *
 
12
 * You should have received a copy of the GNU Lesser General Public
 
13
 * License along with this library; if not, write to the Free Software
 
14
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
15
 */
 
16
 
 
17
 
 
18
 
 
19
/* Written in December 1998 by Roland Orre <orre@nada.kth.se>
 
20
 * This implements the same sort interface as slib/sort.scm
 
21
 * for lists and vectors where slib defines:
 
22
 * sorted?, merge, merge!, sort, sort!
 
23
 * For scsh compatibility sort-list and sort-list! are also defined.
 
24
 * In cases where a stable-sort is required use stable-sort or
 
25
 * stable-sort!.  An additional feature is
 
26
 * (restricted-vector-sort! vector less? startpos endpos)
 
27
 * which allows you to sort part of a vector.
 
28
 * Thanks to Aubrey Jaffer for the slib/sort.scm library.
 
29
 * Thanks to Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
 
30
 * for the merge sort inspiration.
 
31
 * Thanks to Douglas C. Schmidt (schmidt@ics.uci.edu) for the
 
32
 * quicksort code.
 
33
 */
 
34
 
 
35
#include "libguile/_scm.h"
 
36
#include "libguile/eval.h"
 
37
#include "libguile/unif.h"
 
38
#include "libguile/ramap.h"
 
39
#include "libguile/feature.h"
 
40
#include "libguile/vectors.h"
 
41
#include "libguile/lang.h"
 
42
#include "libguile/async.h"
 
43
#include "libguile/dynwind.h"
 
44
 
 
45
#include "libguile/validate.h"
 
46
#include "libguile/sort.h"
 
47
 
 
48
/* We have two quicksort variants: one for contigous vectors and one
 
49
   for vectors with arbitrary increments between elements.  Note that
 
50
   increments can be negative.
 
51
*/
 
52
 
 
53
#define NAME        quicksort1
 
54
#define INC_PARAM   /* empty */
 
55
#define INC         1
 
56
#include "libguile/quicksort.i.c"
 
57
 
 
58
#define NAME        quicksort
 
59
#define INC_PARAM   ssize_t inc,
 
60
#define INC         inc
 
61
#include "libguile/quicksort.i.c"
 
62
 
 
63
static scm_t_trampoline_2
 
64
compare_function (SCM less, unsigned int arg_nr, const char* fname)
 
65
{
 
66
  const scm_t_trampoline_2 cmp = scm_trampoline_2 (less);
 
67
  SCM_ASSERT_TYPE (cmp != NULL, less, arg_nr, fname, "less predicate");
 
68
  return cmp;
 
69
}
 
70
 
 
71
 
 
72
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, 
 
73
            (SCM vec, SCM less, SCM startpos, SCM endpos),
 
74
            "Sort the vector @var{vec}, using @var{less} for comparing\n"
 
75
            "the vector elements.  @var{startpos} (inclusively) and\n"
 
76
            "@var{endpos} (exclusively) delimit\n"
 
77
            "the range of the vector which gets sorted.  The return value\n"
 
78
            "is not specified.")
 
79
#define FUNC_NAME s_scm_restricted_vector_sort_x
 
80
{
 
81
  const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 
82
  size_t vlen, spos, len;
 
83
  ssize_t vinc;
 
84
  scm_t_array_handle handle;
 
85
  SCM *velts;
 
86
 
 
87
  velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
 
88
  spos = scm_to_unsigned_integer (startpos, 0, vlen);
 
89
  len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
 
90
 
 
91
  if (vinc == 1)
 
92
    quicksort1 (velts + spos*vinc, len, cmp, less);
 
93
  else
 
94
    quicksort (velts + spos*vinc, len, vinc, cmp, less);
 
95
 
 
96
  scm_array_handle_release (&handle);
 
97
 
 
98
  return SCM_UNSPECIFIED;
 
99
}
 
100
#undef FUNC_NAME
 
101
 
 
102
 
 
103
/* (sorted? sequence less?)
 
104
 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
 
105
 * such that for all 1 <= i <= m,
 
106
 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
 
107
SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
 
108
            (SCM items, SCM less),
 
109
            "Return @code{#t} iff @var{items} is a list or a vector such that\n"
 
110
            "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
 
111
            "applied to all elements i - 1 and i")
 
112
#define FUNC_NAME s_scm_sorted_p
 
113
{
 
114
  const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 
115
  long len, j;                  /* list/vector length, temp j */
 
116
  SCM item, rest;               /* rest of items loop variable */
 
117
 
 
118
  if (SCM_NULL_OR_NIL_P (items))
 
119
    return SCM_BOOL_T;
 
120
 
 
121
  if (scm_is_pair (items))
 
122
    {
 
123
      len = scm_ilength (items); /* also checks that it's a pure list */
 
124
      SCM_ASSERT_RANGE (1, items, len >= 0);
 
125
      if (len <= 1)
 
126
        return SCM_BOOL_T;
 
127
 
 
128
      item = SCM_CAR (items);
 
129
      rest = SCM_CDR (items);
 
130
      j = len - 1;
 
131
      while (j > 0)
 
132
        {
 
133
          if (scm_is_true ((*cmp) (less, SCM_CAR (rest), item)))
 
134
            return SCM_BOOL_F;
 
135
          else
 
136
            {
 
137
              item = SCM_CAR (rest);
 
138
              rest = SCM_CDR (rest);
 
139
              j--;
 
140
            }
 
141
        }
 
142
      return SCM_BOOL_T;
 
143
    }
 
144
  else
 
145
    {
 
146
      scm_t_array_handle handle;
 
147
      size_t i, len;
 
148
      ssize_t inc;
 
149
      const SCM *elts;
 
150
      SCM result = SCM_BOOL_T;
 
151
 
 
152
      elts = scm_vector_elements (items, &handle, &len, &inc);
 
153
 
 
154
      for (i = 1; i < len; i++, elts += inc)
 
155
        {
 
156
          if (scm_is_true ((*cmp) (less, elts[inc], elts[0])))
 
157
            {
 
158
              result = SCM_BOOL_F;
 
159
              break;
 
160
            }
 
161
        }
 
162
 
 
163
      scm_array_handle_release (&handle);
 
164
 
 
165
      return result;
 
166
    }
 
167
 
 
168
  return SCM_BOOL_F;
 
169
}
 
170
#undef FUNC_NAME
 
171
 
 
172
 
 
173
/* (merge a b less?)
 
174
   takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
 
175
   and returns a new list in which the elements of a and b have been stably
 
176
   interleaved so that (sorted? (merge a b less?) less?).
 
177
   Note:  this does _not_ accept vectors. */
 
178
SCM_DEFINE (scm_merge, "merge", 3, 0, 0, 
 
179
            (SCM alist, SCM blist, SCM less),
 
180
            "Merge two already sorted lists into one.\n"
 
181
            "Given two lists @var{alist} and @var{blist}, such that\n"
 
182
            "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
 
183
            "return a new list in which the elements of @var{alist} and\n"
 
184
            "@var{blist} have been stably interleaved so that\n"
 
185
            "@code{(sorted? (merge alist blist less?) less?)}.\n"
 
186
            "Note:  this does _not_ accept vectors.")
 
187
#define FUNC_NAME s_scm_merge
 
188
{
 
189
  SCM build;
 
190
 
 
191
  if (SCM_NULL_OR_NIL_P (alist))
 
192
    return blist;
 
193
  else if (SCM_NULL_OR_NIL_P (blist))
 
194
    return alist;
 
195
  else
 
196
    {
 
197
      const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
 
198
      long alen, blen;          /* list lengths */
 
199
      SCM last;
 
200
 
 
201
      SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
 
202
      SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
 
203
      if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 
204
        {
 
205
          build = scm_cons (SCM_CAR (blist), SCM_EOL);
 
206
          blist = SCM_CDR (blist);
 
207
          blen--;
 
208
        }
 
209
      else
 
210
        {
 
211
          build = scm_cons (SCM_CAR (alist), SCM_EOL);
 
212
          alist = SCM_CDR (alist);
 
213
          alen--;
 
214
        }
 
215
      last = build;
 
216
      while ((alen > 0) && (blen > 0))
 
217
        {
 
218
          SCM_TICK;
 
219
          if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 
220
            {
 
221
              SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL));
 
222
              blist = SCM_CDR (blist);
 
223
              blen--;
 
224
            }
 
225
          else
 
226
            {
 
227
              SCM_SETCDR (last, scm_cons (SCM_CAR (alist), SCM_EOL));
 
228
              alist = SCM_CDR (alist);
 
229
              alen--;
 
230
            }
 
231
          last = SCM_CDR (last);
 
232
        }
 
233
      if ((alen > 0) && (blen == 0))
 
234
        SCM_SETCDR (last, alist);
 
235
      else if ((alen == 0) && (blen > 0))
 
236
        SCM_SETCDR (last, blist);
 
237
    }
 
238
  return build;
 
239
}
 
240
#undef FUNC_NAME
 
241
 
 
242
 
 
243
static SCM 
 
244
scm_merge_list_x (SCM alist, SCM blist,
 
245
                  long alen, long blen,
 
246
                  scm_t_trampoline_2 cmp, SCM less)
 
247
{
 
248
  SCM build, last;
 
249
 
 
250
  if (SCM_NULL_OR_NIL_P (alist))
 
251
    return blist;
 
252
  else if (SCM_NULL_OR_NIL_P (blist))
 
253
    return alist;
 
254
  else
 
255
    {
 
256
      if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 
257
        {
 
258
          build = blist;
 
259
          blist = SCM_CDR (blist);
 
260
          blen--;
 
261
        }
 
262
      else
 
263
        {
 
264
          build = alist;
 
265
          alist = SCM_CDR (alist);
 
266
          alen--;
 
267
        }
 
268
      last = build;
 
269
      while ((alen > 0) && (blen > 0))
 
270
        {
 
271
          SCM_TICK;
 
272
          if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 
273
            {
 
274
              SCM_SETCDR (last, blist);
 
275
              blist = SCM_CDR (blist);
 
276
              blen--;
 
277
            }
 
278
          else
 
279
            {
 
280
              SCM_SETCDR (last, alist);
 
281
              alist = SCM_CDR (alist);
 
282
              alen--;
 
283
            }
 
284
          last = SCM_CDR (last);
 
285
        }
 
286
      if ((alen > 0) && (blen == 0))
 
287
        SCM_SETCDR (last, alist);
 
288
      else if ((alen == 0) && (blen > 0))
 
289
        SCM_SETCDR (last, blist);
 
290
    }
 
291
  return build;
 
292
}                               /* scm_merge_list_x */
 
293
 
 
294
 
 
295
SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, 
 
296
            (SCM alist, SCM blist, SCM less),
 
297
            "Takes two lists @var{alist} and @var{blist} such that\n"
 
298
            "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
 
299
            "returns a new list in which the elements of @var{alist} and\n"
 
300
            "@var{blist} have been stably interleaved so that\n"
 
301
            " @code{(sorted? (merge alist blist less?) less?)}.\n"
 
302
            "This is the destructive variant of @code{merge}\n"
 
303
            "Note:  this does _not_ accept vectors.")
 
304
#define FUNC_NAME s_scm_merge_x
 
305
{
 
306
  if (SCM_NULL_OR_NIL_P (alist))
 
307
    return blist;
 
308
  else if (SCM_NULL_OR_NIL_P (blist))
 
309
    return alist;
 
310
  else
 
311
    {
 
312
      const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
 
313
      long alen, blen;          /* list lengths */
 
314
      SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
 
315
      SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
 
316
      return scm_merge_list_x (alist, blist, alen, blen, cmp, less);
 
317
    }
 
318
}
 
319
#undef FUNC_NAME
 
320
 
 
321
 
 
322
/* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
 
323
   The algorithm is stable. We also tried to use the algorithm used by
 
324
   scsh's merge-sort but that algorithm showed to not be stable, even
 
325
   though it claimed to be.
 
326
*/
 
327
static SCM 
 
328
scm_merge_list_step (SCM * seq, scm_t_trampoline_2 cmp, SCM less, long n)
 
329
{
 
330
  SCM a, b;
 
331
 
 
332
  if (n > 2)
 
333
    {
 
334
      long mid = n / 2;
 
335
      SCM_TICK;
 
336
      a = scm_merge_list_step (seq, cmp, less, mid);
 
337
      b = scm_merge_list_step (seq, cmp, less, n - mid);
 
338
      return scm_merge_list_x (a, b, mid, n - mid, cmp, less);
 
339
    }
 
340
  else if (n == 2)
 
341
    {
 
342
      SCM p = *seq;
 
343
      SCM rest = SCM_CDR (*seq);
 
344
      SCM x = SCM_CAR (*seq);
 
345
      SCM y = SCM_CAR (SCM_CDR (*seq));
 
346
      *seq = SCM_CDR (rest);
 
347
      SCM_SETCDR (rest, SCM_EOL);
 
348
      if (scm_is_true ((*cmp) (less, y, x)))
 
349
        {
 
350
          SCM_SETCAR (p, y);
 
351
          SCM_SETCAR (rest, x);
 
352
        }
 
353
      return p;
 
354
    }
 
355
  else if (n == 1)
 
356
    {
 
357
      SCM p = *seq;
 
358
      *seq = SCM_CDR (p);
 
359
      SCM_SETCDR (p, SCM_EOL);
 
360
      return p;
 
361
    }
 
362
  else
 
363
    return SCM_EOL;
 
364
}                               /* scm_merge_list_step */
 
365
 
 
366
 
 
367
SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, 
 
368
            (SCM items, SCM less),
 
369
            "Sort the sequence @var{items}, which may be a list or a\n"
 
370
            "vector.  @var{less} is used for comparing the sequence\n"
 
371
            "elements.  The sorting is destructive, that means that the\n"
 
372
            "input sequence is modified to produce the sorted result.\n"
 
373
            "This is not a stable sort.")
 
374
#define FUNC_NAME s_scm_sort_x
 
375
{
 
376
  long len;                     /* list/vector length */
 
377
  if (SCM_NULL_OR_NIL_P (items))
 
378
    return items;
 
379
 
 
380
  if (scm_is_pair (items))
 
381
    {
 
382
      const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 
383
      SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 
384
      return scm_merge_list_step (&items, cmp, less, len);
 
385
    }
 
386
  else if (scm_is_vector (items))
 
387
    {
 
388
      scm_restricted_vector_sort_x (items,
 
389
                                    less,
 
390
                                    scm_from_int (0),
 
391
                                    scm_vector_length (items));
 
392
      return items;
 
393
    }
 
394
  else
 
395
    SCM_WRONG_TYPE_ARG (1, items);
 
396
}
 
397
#undef FUNC_NAME
 
398
 
 
399
 
 
400
SCM_DEFINE (scm_sort, "sort", 2, 0, 0, 
 
401
            (SCM items, SCM less),
 
402
            "Sort the sequence @var{items}, which may be a list or a\n"
 
403
            "vector.  @var{less} is used for comparing the sequence\n"
 
404
            "elements.  This is not a stable sort.")
 
405
#define FUNC_NAME s_scm_sort
 
406
{
 
407
  if (SCM_NULL_OR_NIL_P (items))
 
408
    return items;
 
409
 
 
410
  if (scm_is_pair (items))
 
411
    return scm_sort_x (scm_list_copy (items), less);
 
412
  else if (scm_is_vector (items))
 
413
    return scm_sort_x (scm_vector_copy (items), less);
 
414
  else
 
415
    SCM_WRONG_TYPE_ARG (1, items);
 
416
}
 
417
#undef FUNC_NAME
 
418
 
 
419
 
 
420
static void
 
421
scm_merge_vector_x (SCM *vec,
 
422
                    SCM *temp,
 
423
                    scm_t_trampoline_2 cmp,
 
424
                    SCM less,
 
425
                    size_t low,
 
426
                    size_t mid,
 
427
                    size_t high,
 
428
                    ssize_t inc)
 
429
{
 
430
  size_t it;            /* Index for temp vector */
 
431
  size_t i1 = low;      /* Index for lower vector segment */
 
432
  size_t i2 = mid + 1;  /* Index for upper vector segment */
 
433
 
 
434
#define VEC(i) vec[(i)*inc]
 
435
 
 
436
  /* Copy while both segments contain more characters */
 
437
  for (it = low; (i1 <= mid) && (i2 <= high); ++it)
 
438
    {
 
439
      if (scm_is_true ((*cmp) (less, VEC(i2), VEC(i1))))
 
440
        temp[it] = VEC(i2++);
 
441
      else
 
442
        temp[it] = VEC(i1++);
 
443
    }
 
444
 
 
445
  {
 
446
    /* Copy while first segment contains more characters */
 
447
    while (i1 <= mid)
 
448
      temp[it++] = VEC(i1++);
 
449
 
 
450
    /* Copy while second segment contains more characters */
 
451
    while (i2 <= high)
 
452
      temp[it++] = VEC(i2++);
 
453
 
 
454
    /* Copy back from temp to vp */
 
455
    for (it = low; it <= high; it++)
 
456
      VEC(it) = temp[it];
 
457
  }
 
458
}                               /* scm_merge_vector_x */
 
459
 
 
460
 
 
461
static void
 
462
scm_merge_vector_step (SCM *vec,
 
463
                       SCM *temp,
 
464
                       scm_t_trampoline_2 cmp,
 
465
                       SCM less,
 
466
                       size_t low,
 
467
                       size_t high,
 
468
                       ssize_t inc)
 
469
{
 
470
  if (high > low)
 
471
    {
 
472
      size_t mid = (low + high) / 2;
 
473
      SCM_TICK;
 
474
      scm_merge_vector_step (vec, temp, cmp, less, low, mid, inc);
 
475
      scm_merge_vector_step (vec, temp, cmp, less, mid+1, high, inc);
 
476
      scm_merge_vector_x (vec, temp, cmp, less, low, mid, high, inc);
 
477
    }
 
478
}                               /* scm_merge_vector_step */
 
479
 
 
480
 
 
481
SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, 
 
482
            (SCM items, SCM less),
 
483
            "Sort the sequence @var{items}, which may be a list or a\n"
 
484
            "vector. @var{less} is used for comparing the sequence elements.\n"
 
485
            "The sorting is destructive, that means that the input sequence\n"
 
486
            "is modified to produce the sorted result.\n"
 
487
            "This is a stable sort.")
 
488
#define FUNC_NAME s_scm_stable_sort_x
 
489
{
 
490
  const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 
491
  long len;                     /* list/vector length */
 
492
 
 
493
  if (SCM_NULL_OR_NIL_P (items))
 
494
    return items;
 
495
 
 
496
  if (scm_is_pair (items))
 
497
    {
 
498
      SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 
499
      return scm_merge_list_step (&items, cmp, less, len);
 
500
    }
 
501
  else if (scm_is_vector (items))
 
502
    {
 
503
      scm_t_array_handle temp_handle, vec_handle;
 
504
      SCM temp, *temp_elts, *vec_elts;
 
505
      size_t len;
 
506
      ssize_t inc;
 
507
      
 
508
      vec_elts = scm_vector_writable_elements (items, &vec_handle,
 
509
                                               &len, &inc);
 
510
      temp = scm_c_make_vector (len, SCM_UNDEFINED);
 
511
      temp_elts = scm_vector_writable_elements (temp, &temp_handle,
 
512
                                                NULL, NULL);
 
513
 
 
514
      scm_merge_vector_step (vec_elts, temp_elts, cmp, less, 0, len-1, inc);
 
515
 
 
516
      scm_array_handle_release (&temp_handle);
 
517
      scm_array_handle_release (&vec_handle);
 
518
 
 
519
      return items;
 
520
    }
 
521
  else
 
522
    SCM_WRONG_TYPE_ARG (1, items);
 
523
}
 
524
#undef FUNC_NAME
 
525
 
 
526
 
 
527
SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, 
 
528
            (SCM items, SCM less),
 
529
            "Sort the sequence @var{items}, which may be a list or a\n"
 
530
            "vector. @var{less} is used for comparing the sequence elements.\n"
 
531
            "This is a stable sort.")
 
532
#define FUNC_NAME s_scm_stable_sort
 
533
{
 
534
  if (scm_is_pair (items))
 
535
    return scm_stable_sort_x (scm_list_copy (items), less);
 
536
  else if (scm_is_vector (items))
 
537
    return scm_stable_sort_x (scm_vector_copy (items), less);
 
538
  else
 
539
    SCM_WRONG_TYPE_ARG (1, items);
 
540
}
 
541
#undef FUNC_NAME
 
542
 
 
543
 
 
544
SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0, 
 
545
            (SCM items, SCM less),
 
546
            "Sort the list @var{items}, using @var{less} for comparing the\n"
 
547
            "list elements. The sorting is destructive, that means that the\n"
 
548
            "input list is modified to produce the sorted result.\n"
 
549
            "This is a stable sort.")
 
550
#define FUNC_NAME s_scm_sort_list_x
 
551
{
 
552
  const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 
553
  long len;
 
554
 
 
555
  SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 
556
  return scm_merge_list_step (&items, cmp, less, len);
 
557
}
 
558
#undef FUNC_NAME
 
559
 
 
560
 
 
561
SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0, 
 
562
            (SCM items, SCM less),
 
563
            "Sort the list @var{items}, using @var{less} for comparing the\n"
 
564
            "list elements. This is a stable sort.")
 
565
#define FUNC_NAME s_scm_sort_list
 
566
{
 
567
  const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 
568
  long len;
 
569
 
 
570
  SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 
571
  items = scm_list_copy (items);
 
572
  return scm_merge_list_step (&items, cmp, less, len);
 
573
}
 
574
#undef FUNC_NAME
 
575
 
 
576
 
 
577
void
 
578
scm_init_sort ()
 
579
{
 
580
#include "libguile/sort.x"
 
581
 
 
582
  scm_add_feature ("sort");
 
583
}
 
584
 
 
585
/*
 
586
  Local Variables:
 
587
  c-file-style: "gnu"
 
588
  End:
 
589
*/