1 /* Copyright (C) 1999,2000,2001 Free Software Foundation, Inc.
2 * This program is free software; you can redistribute it and/or modify
3 * it under the terms of the GNU General Public License as published by
4 * the Free Software Foundation; either version 2, or (at your option)
7 * This program 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
10 * GNU General Public License for more details.
12 * You should have received a copy of the GNU General Public License
13 * along with this software; see the file COPYING. If not, write to
14 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
15 * Boston, MA 02111-1307 USA
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * If you do not wish that, delete this exception notice. */
41 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
42 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
45 /* Written in December 1998 by Roland Orre <orre@nada.kth.se>
46 * This implements the same sort interface as slib/sort.scm
47 * for lists and vectors where slib defines:
48 * sorted?, merge, merge!, sort, sort!
49 * For scsh compatibility sort-list and sort-list! are also defined.
50 * In cases where a stable-sort is required use stable-sort or
51 * stable-sort!. An additional feature is
52 * (restricted-vector-sort! vector less? startpos endpos)
53 * which allows you to sort part of a vector.
54 * Thanks to Aubrey Jaffer for the slib/sort.scm library.
55 * Thanks to Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
56 * for the merge sort inspiration.
57 * Thanks to Douglas C. Schmidt (schmidt@ics.uci.edu) for the
61 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
62 #include "libguile/scmconfig.h"
64 /* AIX requires this to be the first thing in the file. The #pragma
65 directive is indented so pre-ANSI compilers will ignore it, rather
74 # ifndef alloca /* predefined by HP cc +Olibcalls */
82 #include "libguile/_scm.h"
84 #include "libguile/eval.h"
85 #include "libguile/unif.h"
86 #include "libguile/ramap.h"
87 #include "libguile/alist.h"
88 #include "libguile/feature.h"
89 #include "libguile/root.h"
90 #include "libguile/vectors.h"
92 #include "libguile/validate.h"
93 #include "libguile/sort.h"
95 /* The routine quicksort was extracted from the GNU C Library qsort.c
96 written by Douglas C. Schmidt (schmidt@ics.uci.edu)
97 and adapted to guile by adding an extra pointer less
98 to quicksort by Roland Orre <orre@nada.kth.se>.
100 The reason to do this instead of using the library function qsort
101 was to avoid dependency of the ANSI-C extensions for local functions
102 and also to avoid obscure pool based solutions.
104 This sorting routine is not much more efficient than the stable
105 version but doesn't consume extra memory.
108 /* Byte-wise swap two items of size SIZE. */
109 #define SWAP(a, b, size) \
112 register size_t __size = (size); \
113 register char *__a = (a), *__b = (b); \
119 } while (--__size > 0); \
122 /* Discontinue quicksort algorithm when partition gets below this size.
123 This particular magic number was chosen to work best on a Sun 4/260. */
126 /* Stack node declarations used to store unfulfilled partition obligations. */
134 /* The next 4 #defines implement a very fast in-line stack abstraction. */
135 #define STACK_SIZE (8 * sizeof(unsigned long int))
136 #define PUSH(low, high) ((void) ((top->lo = (low)), (top->hi = (high)), ++top))
137 #define POP(low, high) ((void) (--top, (low = top->lo), (high = top->hi)))
138 #define STACK_NOT_EMPTY (stack < top)
141 /* Order size using quicksort. This implementation incorporates
142 four optimizations discussed in Sedgewick:
144 1. Non-recursive, using an explicit stack of pointer that store the
145 next array partition to sort. To save time, this maximum amount
146 of space required to store an array of MAX_INT is allocated on the
147 stack. Assuming a 32-bit integer, this needs only 32 *
148 sizeof(stack_node) == 136 bits. Pretty cheap, actually.
150 2. Chose the pivot element using a median-of-three decision tree.
151 This reduces the probability of selecting a bad pivot value and
152 eliminates certain extraneous comparisons.
154 3. Only quicksorts TOTAL_ELEMS / MAX_THRESH partitions, leaving
155 insertion sort to order the MAX_THRESH items within each partition.
156 This is a big win, since insertion sort is faster for small, mostly
157 sorted array segments.
159 4. The larger of the two sub-partitions is always pushed onto the
160 stack first, with the algorithm then concentrating on the
161 smaller partition. This *guarantees* no more than log (n)
162 stack size is needed (actually O(1) in this case)! */
164 typedef int (*cmp_fun_t
) (SCM less
,
168 static const char s_buggy_less
[] = "buggy less predicate used when sorting";
171 quicksort (void *const pbase
,
177 register char *base_ptr
= (char *) pbase
;
179 /* Allocating SIZE bytes for a pivot buffer facilitates a better
180 algorithm below since we can do comparisons directly on the pivot. */
181 char *pivot_buffer
= (char *) alloca (size
);
182 const size_t max_thresh
= MAX_THRESH
* size
;
184 if (total_elems
== 0)
185 /* Avoid lossage with unsigned arithmetic below. */
188 if (total_elems
> MAX_THRESH
)
191 char *hi
= &lo
[size
* (total_elems
- 1)];
192 /* Largest size needed for 32-bit int!!! */
193 stack_node stack
[STACK_SIZE
];
194 stack_node
*top
= stack
+ 1;
196 while (STACK_NOT_EMPTY
)
201 char *pivot
= pivot_buffer
;
203 /* Select median value from among LO, MID, and HI. Rearrange
204 LO and HI so the three values are sorted. This lowers the
205 probability of picking a pathological pivot value and
206 skips a comparison for both the LEFT_PTR and RIGHT_PTR. */
208 char *mid
= lo
+ size
* ((hi
- lo
) / size
>> 1);
210 if ((*cmp
) (less
, (void *) mid
, (void *) lo
))
211 SWAP (mid
, lo
, size
);
212 if ((*cmp
) (less
, (void *) hi
, (void *) mid
))
213 SWAP (mid
, hi
, size
);
216 if ((*cmp
) (less
, (void *) mid
, (void *) lo
))
217 SWAP (mid
, lo
, size
);
219 memcpy (pivot
, mid
, size
);
220 pivot
= pivot_buffer
;
222 left_ptr
= lo
+ size
;
223 right_ptr
= hi
- size
;
225 /* Here's the famous ``collapse the walls'' section of quicksort.
226 Gotta like those tight inner loops! They are the main reason
227 that this algorithm runs much faster than others. */
230 while ((*cmp
) (less
, (void *) left_ptr
, (void *) pivot
))
233 /* The comparison predicate may be buggy */
235 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
238 while ((*cmp
) (less
, (void *) pivot
, (void *) right_ptr
))
241 /* The comparison predicate may be buggy */
243 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
246 if (left_ptr
< right_ptr
)
248 SWAP (left_ptr
, right_ptr
, size
);
252 else if (left_ptr
== right_ptr
)
259 while (left_ptr
<= right_ptr
);
261 /* Set up pointers for next iteration. First determine whether
262 left and right partitions are below the threshold size. If so,
263 ignore one or both. Otherwise, push the larger partition's
264 bounds on the stack and continue sorting the smaller one. */
266 if ((size_t) (right_ptr
- lo
) <= max_thresh
)
268 if ((size_t) (hi
- left_ptr
) <= max_thresh
)
269 /* Ignore both small partitions. */
272 /* Ignore small left partition. */
275 else if ((size_t) (hi
- left_ptr
) <= max_thresh
)
276 /* Ignore small right partition. */
278 else if ((right_ptr
- lo
) > (hi
- left_ptr
))
280 /* Push larger left partition indices. */
281 PUSH (lo
, right_ptr
);
286 /* Push larger right partition indices. */
293 /* Once the BASE_PTR array is partially sorted by quicksort the rest
294 is completely sorted using insertion sort, since this is efficient
295 for partitions below MAX_THRESH size. BASE_PTR points to the beginning
296 of the array to sort, and END_PTR points at the very last element in
297 the array (*not* one beyond it!). */
300 char *const end_ptr
= &base_ptr
[size
* (total_elems
- 1)];
301 char *tmp_ptr
= base_ptr
;
302 char *thresh
= min (end_ptr
, base_ptr
+ max_thresh
);
303 register char *run_ptr
;
305 /* Find smallest element in first threshold and place it at the
306 array's beginning. This is the smallest array element,
307 and the operation speeds up insertion sort's inner loop. */
309 for (run_ptr
= tmp_ptr
+ size
; run_ptr
<= thresh
; run_ptr
+= size
)
310 if ((*cmp
) (less
, (void *) run_ptr
, (void *) tmp_ptr
))
313 if (tmp_ptr
!= base_ptr
)
314 SWAP (tmp_ptr
, base_ptr
, size
);
316 /* Insertion sort, running from left-hand-side up to right-hand-side. */
318 run_ptr
= base_ptr
+ size
;
319 while ((run_ptr
+= size
) <= end_ptr
)
321 tmp_ptr
= run_ptr
- size
;
322 while ((*cmp
) (less
, (void *) run_ptr
, (void *) tmp_ptr
))
325 /* The comparison predicate may be buggy */
326 if (tmp_ptr
< base_ptr
)
327 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
331 if (tmp_ptr
!= run_ptr
)
335 trav
= run_ptr
+ size
;
336 while (--trav
>= run_ptr
)
341 for (hi
= lo
= trav
; (lo
-= size
) >= tmp_ptr
; hi
= lo
)
351 /* comparison routines */
354 subr2less (SCM less
, const void *a
, const void *b
)
356 return SCM_NFALSEP (SCM_SUBRF (less
) (*(SCM
*) a
, *(SCM
*) b
));
360 subr2oless (SCM less
, const void *a
, const void *b
)
362 return SCM_NFALSEP (SCM_SUBRF (less
) (*(SCM
*) a
,
368 lsubrless (SCM less
, const void *a
, const void *b
)
370 return SCM_NFALSEP (SCM_SUBRF (less
)
371 (scm_cons (*(SCM
*) a
,
372 scm_cons (*(SCM
*) b
, SCM_EOL
))));
376 closureless (SCM code
, const void *a
, const void *b
)
378 SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
379 scm_cons (*(SCM
*) a
,
380 scm_cons (*(SCM
*) b
, SCM_EOL
)),
382 /* Evaluate the closure body */
383 return SCM_NFALSEP (scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
));
387 applyless (SCM less
, const void *a
, const void *b
)
389 return SCM_NFALSEP (scm_call_2 (less
, *(SCM
*) a
, *(SCM
*) b
));
393 scm_cmp_function (SCM p
)
395 switch (SCM_TYP7 (p
))
401 case scm_tc7_subr_2o
:
405 case scm_tcs_closures
:
410 } /* scm_cmp_function */
413 /* Question: Is there any need to make this a more general array sort?
414 It is probably enough to manage the vector type. */
415 /* endpos equal as for substring, i.e. endpos is not included. */
416 /* More natural with length? */
418 SCM_DEFINE (scm_restricted_vector_sort_x
, "restricted-vector-sort!", 4, 0, 0,
419 (SCM vec
, SCM less
, SCM startpos
, SCM endpos
),
420 "Sort the vector @var{vec}, using @var{less} for comparing\n"
421 "the vector elements. @var{startpos} and @var{endpos} delimit\n"
422 "the range of the vector which gets sorted. The return value\n"
424 #define FUNC_NAME s_scm_restricted_vector_sort_x
426 size_t vlen
, spos
, len
, size
= sizeof (SCM
);
429 SCM_VALIDATE_VECTOR (1,vec
);
430 SCM_VALIDATE_NIM (2,less
);
432 vp
= SCM_VELTS (vec
); /* vector pointer */
433 vlen
= SCM_VECTOR_LENGTH (vec
);
435 SCM_VALIDATE_INUM_MIN_COPY (3, startpos
, 0, spos
);
436 SCM_ASSERT_RANGE (3,startpos
, spos
<= vlen
);
437 SCM_VALIDATE_INUM_RANGE (4,endpos
,0,vlen
+1);
438 len
= SCM_INUM (endpos
) - spos
;
440 quicksort (&vp
[spos
], len
, size
, scm_cmp_function (less
), less
);
441 return SCM_UNSPECIFIED
;
446 /* (sorted? sequence less?)
447 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
448 * such that for all 1 <= i <= m,
449 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
450 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
451 (SCM items
, SCM less
),
452 "Return @code{#t} iff @var{items} is a list or a vector such that\n"
453 "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
454 "applied to all elements i - 1 and i")
455 #define FUNC_NAME s_scm_sorted_p
457 long len
, j
; /* list/vector length, temp j */
458 SCM item
, rest
; /* rest of items loop variable */
460 cmp_fun_t cmp
= scm_cmp_function (less
);
462 if (SCM_NULLP (items
))
465 SCM_VALIDATE_NIM (2,less
);
467 if (SCM_CONSP (items
))
469 len
= scm_ilength (items
); /* also checks that it's a pure list */
470 SCM_ASSERT_RANGE (1,items
,len
>= 0);
474 item
= SCM_CAR (items
);
475 rest
= SCM_CDR (items
);
479 if ((*cmp
) (less
, SCM_CARLOC(rest
), &item
))
483 item
= SCM_CAR (rest
);
484 rest
= SCM_CDR (rest
);
492 SCM_VALIDATE_VECTOR (1, items
);
494 vp
= SCM_VELTS (items
); /* vector pointer */
495 len
= SCM_VECTOR_LENGTH (items
);
499 if ((*cmp
) (less
, &vp
[1], vp
))
515 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
516 and returns a new list in which the elements of a and b have been stably
517 interleaved so that (sorted? (merge a b less?) less?).
518 Note: this does _not_ accept vectors. */
519 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
520 (SCM alist
, SCM blist
, SCM less
),
521 "Takes two lists @var{alist} and @var{blist} such that\n"
522 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
523 "returns a new list in which the elements of @var{alist} and\n"
524 "@var{blist} have been stably interleaved so that\n"
525 "@code{(sorted? (merge alist blist less?) less?)}.\n"
526 "Note: this does _not_ accept vectors.")
527 #define FUNC_NAME s_scm_merge
529 long alen
, blen
; /* list lengths */
531 cmp_fun_t cmp
= scm_cmp_function (less
);
532 SCM_VALIDATE_NIM (3,less
);
534 if (SCM_NULLP (alist
))
536 else if (SCM_NULLP (blist
))
540 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1,alist
,alen
);
541 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2,blist
,blen
);
542 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
544 build
= scm_cons (SCM_CAR (blist
), SCM_EOL
);
545 blist
= SCM_CDR (blist
);
550 build
= scm_cons (SCM_CAR (alist
), SCM_EOL
);
551 alist
= SCM_CDR (alist
);
555 while ((alen
> 0) && (blen
> 0))
557 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
559 SCM_SETCDR (last
, scm_cons (SCM_CAR (blist
), SCM_EOL
));
560 blist
= SCM_CDR (blist
);
565 SCM_SETCDR (last
, scm_cons (SCM_CAR (alist
), SCM_EOL
));
566 alist
= SCM_CDR (alist
);
569 last
= SCM_CDR (last
);
571 if ((alen
> 0) && (blen
== 0))
572 SCM_SETCDR (last
, alist
);
573 else if ((alen
== 0) && (blen
> 0))
574 SCM_SETCDR (last
, blist
);
582 scm_merge_list_x (SCM alist
, SCM blist
,
583 long alen
, long blen
,
584 cmp_fun_t cmp
, SCM less
)
588 if (SCM_NULLP (alist
))
590 else if (SCM_NULLP (blist
))
594 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
597 blist
= SCM_CDR (blist
);
603 alist
= SCM_CDR (alist
);
607 while ((alen
> 0) && (blen
> 0))
609 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
611 SCM_SETCDR (last
, blist
);
612 blist
= SCM_CDR (blist
);
617 SCM_SETCDR (last
, alist
);
618 alist
= SCM_CDR (alist
);
621 last
= SCM_CDR (last
);
623 if ((alen
> 0) && (blen
== 0))
624 SCM_SETCDR (last
, alist
);
625 else if ((alen
== 0) && (blen
> 0))
626 SCM_SETCDR (last
, blist
);
629 } /* scm_merge_list_x */
631 SCM_DEFINE (scm_merge_x
, "merge!", 3, 0, 0,
632 (SCM alist
, SCM blist
, SCM less
),
633 "Takes two lists @var{alist} and @var{blist} such that\n"
634 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
635 "returns a new list in which the elements of @var{alist} and\n"
636 "@var{blist} have been stably interleaved so that\n"
637 " @code{(sorted? (merge alist blist less?) less?)}.\n"
638 "This is the destructive variant of @code{merge}\n"
639 "Note: this does _not_ accept vectors.")
640 #define FUNC_NAME s_scm_merge_x
642 long alen
, blen
; /* list lengths */
644 SCM_VALIDATE_NIM (3,less
);
645 if (SCM_NULLP (alist
))
647 else if (SCM_NULLP (blist
))
651 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1,alist
,alen
);
652 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2,blist
,blen
);
653 return scm_merge_list_x (alist
, blist
,
655 scm_cmp_function (less
),
661 /* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
662 The algorithm is stable. We also tried to use the algorithm used by
663 scsh's merge-sort but that algorithm showed to not be stable, even
664 though it claimed to be.
667 scm_merge_list_step (SCM
* seq
,
677 a
= scm_merge_list_step (seq
, cmp
, less
, mid
);
678 b
= scm_merge_list_step (seq
, cmp
, less
, n
- mid
);
679 return scm_merge_list_x (a
, b
, mid
, n
- mid
, cmp
, less
);
684 SCM rest
= SCM_CDR (*seq
);
685 SCM x
= SCM_CAR (*seq
);
686 SCM y
= SCM_CAR (SCM_CDR (*seq
));
687 *seq
= SCM_CDR (rest
);
688 SCM_SETCDR (rest
, SCM_EOL
);
689 if ((*cmp
) (less
, &y
, &x
))
692 SCM_SETCAR (rest
, x
);
700 SCM_SETCDR (p
, SCM_EOL
);
705 } /* scm_merge_list_step */
708 /* scm_sort_x manages lists and vectors, not stable sort */
709 SCM_DEFINE (scm_sort_x
, "sort!", 2, 0, 0,
710 (SCM items
, SCM less
),
711 "Sort the sequence @var{items}, which may be a list or a\n"
712 "vector. @var{less} is used for comparing the sequence\n"
713 "elements. The sorting is destructive, that means that the\n"
714 "input sequence is modified to produce the sorted result.\n"
715 "This is not a stable sort.")
716 #define FUNC_NAME s_scm_sort_x
718 long len
; /* list/vector length */
719 if (SCM_NULLP(items
))
722 SCM_VALIDATE_NIM (2,less
);
724 if (SCM_CONSP (items
))
726 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
727 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
729 else if (SCM_VECTORP (items
))
731 len
= SCM_VECTOR_LENGTH (items
);
732 scm_restricted_vector_sort_x (items
,
739 SCM_WRONG_TYPE_ARG (1, items
);
743 /* scm_sort manages lists and vectors, not stable sort */
745 SCM_DEFINE (scm_sort
, "sort", 2, 0, 0,
746 (SCM items
, SCM less
),
747 "Sort the sequence @var{items}, which may be a list or a\n"
748 "vector. @var{less} is used for comparing the sequence\n"
749 "elements. This is not a stable sort.")
750 #define FUNC_NAME s_scm_sort
752 if (SCM_NULLP(items
))
755 SCM_VALIDATE_NIM (2,less
);
756 if (SCM_CONSP (items
))
760 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
761 items
= scm_list_copy (items
);
762 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
765 /* support ordinary vectors even if arrays not available? */
766 else if (SCM_VECTORP (items
))
768 long len
= SCM_VECTOR_LENGTH (items
);
769 SCM sortvec
= scm_make_uve (len
, scm_array_prototype (items
));
771 scm_array_copy_x (items
, sortvec
);
772 scm_restricted_vector_sort_x (sortvec
,
780 SCM_WRONG_TYPE_ARG (1, items
);
785 scm_merge_vector_x (void *const vecbase
,
786 void *const tempbase
,
793 register SCM
*vp
= (SCM
*) vecbase
;
794 register SCM
*temp
= (SCM
*) tempbase
;
795 long it
; /* Index for temp vector */
796 long i1
= low
; /* Index for lower vector segment */
797 long i2
= mid
+ 1; /* Index for upper vector segment */
799 /* Copy while both segments contain more characters */
800 for (it
= low
; (i1
<= mid
) && (i2
<= high
); ++it
)
801 if ((*cmp
) (less
, &vp
[i2
], &vp
[i1
]))
806 /* Copy while first segment contains more characters */
808 temp
[it
++] = vp
[i1
++];
810 /* Copy while second segment contains more characters */
812 temp
[it
++] = vp
[i2
++];
814 /* Copy back from temp to vp */
815 for (it
= low
; it
<= high
; ++it
)
817 } /* scm_merge_vector_x */
820 scm_merge_vector_step (void *const vp
,
829 long mid
= (low
+ high
) / 2;
830 scm_merge_vector_step (vp
, temp
, cmp
, less
, low
, mid
);
831 scm_merge_vector_step (vp
, temp
, cmp
, less
, mid
+1, high
);
832 scm_merge_vector_x (vp
, temp
, cmp
, less
, low
, mid
, high
);
834 } /* scm_merge_vector_step */
837 /* stable-sort! manages lists and vectors */
839 SCM_DEFINE (scm_stable_sort_x
, "stable-sort!", 2, 0, 0,
840 (SCM items
, SCM less
),
841 "Sort the sequence @var{items}, which may be a list or a\n"
842 "vector. @var{less} is used for comparing the sequence elements.\n"
843 "The sorting is destructive, that means that the input sequence\n"
844 "is modified to produce the sorted result.\n"
845 "This is a stable sort.")
846 #define FUNC_NAME s_scm_stable_sort_x
848 long len
; /* list/vector length */
850 if (SCM_NULLP (items
))
853 SCM_VALIDATE_NIM (2,less
);
854 if (SCM_CONSP (items
))
856 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
857 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
859 else if (SCM_VECTORP (items
))
862 len
= SCM_VECTOR_LENGTH (items
);
863 temp
= malloc (len
* sizeof(SCM
));
864 vp
= SCM_VELTS (items
);
865 scm_merge_vector_step (vp
,
867 scm_cmp_function (less
),
875 SCM_WRONG_TYPE_ARG (1, items
);
879 /* stable_sort manages lists and vectors */
881 SCM_DEFINE (scm_stable_sort
, "stable-sort", 2, 0, 0,
882 (SCM items
, SCM less
),
883 "Sort the sequence @var{items}, which may be a list or a\n"
884 "vector. @var{less} is used for comparing the sequence elements.\n"
885 "This is a stable sort.")
886 #define FUNC_NAME s_scm_stable_sort
888 long len
; /* list/vector length */
889 if (SCM_NULLP (items
))
892 SCM_VALIDATE_NIM (2,less
);
893 if (SCM_CONSP (items
))
895 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
896 items
= scm_list_copy (items
);
897 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
900 /* support ordinary vectors even if arrays not available? */
901 else if (SCM_VECTORP (items
))
905 len
= SCM_VECTOR_LENGTH (items
);
906 retvec
= scm_make_uve (len
, scm_array_prototype (items
));
907 scm_array_copy_x (items
, retvec
);
908 temp
= malloc (len
* sizeof (SCM
));
909 vp
= SCM_VELTS (retvec
);
910 scm_merge_vector_step (vp
,
912 scm_cmp_function (less
),
921 SCM_WRONG_TYPE_ARG (1, items
);
926 SCM_DEFINE (scm_sort_list_x
, "sort-list!", 2, 0, 0,
927 (SCM items
, SCM less
),
928 "Sort the list @var{items}, using @var{less} for comparing the\n"
929 "list elements. The sorting is destructive, that means that the\n"
930 "input list is modified to produce the sorted result.\n"
931 "This is a stable sort.")
932 #define FUNC_NAME s_scm_sort_list_x
935 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
936 SCM_VALIDATE_NIM (2,less
);
937 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
942 SCM_DEFINE (scm_sort_list
, "sort-list", 2, 0, 0,
943 (SCM items
, SCM less
),
944 "Sort the list @var{items}, using @var{less} for comparing the\n"
945 "list elements. This is a stable sort.")
946 #define FUNC_NAME s_scm_sort_list
949 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
950 SCM_VALIDATE_NIM (2,less
);
951 items
= scm_list_copy (items
);
952 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
959 #ifndef SCM_MAGIC_SNARFER
960 #include "libguile/sort.x"
963 scm_add_feature ("sort");