1 /* Copyright (C) 1999,2000,2001,2002 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.
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.
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
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
35 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
40 /* do we still need this here? */
41 #include "libguile/scmconfig.h"
43 /* AIX requires this to be the first thing in the file. The #pragma
44 directive is indented so pre-ANSI compilers will ignore it, rather
53 # ifndef alloca /* predefined by HP cc +Olibcalls */
61 #include "libguile/_scm.h"
63 #include "libguile/eval.h"
64 #include "libguile/unif.h"
65 #include "libguile/ramap.h"
66 #include "libguile/alist.h"
67 #include "libguile/feature.h"
68 #include "libguile/root.h"
69 #include "libguile/vectors.h"
70 #include "libguile/lang.h"
72 #include "libguile/validate.h"
73 #include "libguile/sort.h"
75 /* The routine quicksort was extracted from the GNU C Library qsort.c
76 written by Douglas C. Schmidt (schmidt@ics.uci.edu)
77 and adapted to guile by adding an extra pointer less
78 to quicksort by Roland Orre <orre@nada.kth.se>.
80 The reason to do this instead of using the library function qsort
81 was to avoid dependency of the ANSI-C extensions for local functions
82 and also to avoid obscure pool based solutions.
84 This sorting routine is not much more efficient than the stable
85 version but doesn't consume extra memory.
88 /* Byte-wise swap two items of size SIZE. */
89 #define SWAP(a, b, size) \
92 register size_t __size = (size); \
93 register char *__a = (a), *__b = (b); \
99 } while (--__size > 0); \
102 /* Discontinue quicksort algorithm when partition gets below this size.
103 This particular magic number was chosen to work best on a Sun 4/260. */
106 /* Stack node declarations used to store unfulfilled partition obligations. */
114 /* The next 4 #defines implement a very fast in-line stack abstraction. */
115 #define STACK_SIZE (8 * sizeof(unsigned long int))
116 #define PUSH(low, high) ((void) ((top->lo = (low)), (top->hi = (high)), ++top))
117 #define POP(low, high) ((void) (--top, (low = top->lo), (high = top->hi)))
118 #define STACK_NOT_EMPTY (stack < top)
121 /* Order size using quicksort. This implementation incorporates
122 four optimizations discussed in Sedgewick:
124 1. Non-recursive, using an explicit stack of pointer that store the
125 next array partition to sort. To save time, this maximum amount
126 of space required to store an array of MAX_INT is allocated on the
127 stack. Assuming a 32-bit integer, this needs only 32 *
128 sizeof(stack_node) == 136 bits. Pretty cheap, actually.
130 2. Chose the pivot element using a median-of-three decision tree.
131 This reduces the probability of selecting a bad pivot value and
132 eliminates certain extraneous comparisons.
134 3. Only quicksorts TOTAL_ELEMS / MAX_THRESH partitions, leaving
135 insertion sort to order the MAX_THRESH items within each partition.
136 This is a big win, since insertion sort is faster for small, mostly
137 sorted array segments.
139 4. The larger of the two sub-partitions is always pushed onto the
140 stack first, with the algorithm then concentrating on the
141 smaller partition. This *guarantees* no more than log (n)
142 stack size is needed (actually O(1) in this case)! */
144 typedef int (*cmp_fun_t
) (SCM less
,
148 static const char s_buggy_less
[] = "buggy less predicate used when sorting";
151 quicksort (void *const pbase
,
157 register char *base_ptr
= (char *) pbase
;
159 /* Allocating SIZE bytes for a pivot buffer facilitates a better
160 algorithm below since we can do comparisons directly on the pivot. */
161 char *pivot_buffer
= (char *) alloca (size
);
162 const size_t max_thresh
= MAX_THRESH
* size
;
164 if (total_elems
== 0)
165 /* Avoid lossage with unsigned arithmetic below. */
168 if (total_elems
> MAX_THRESH
)
171 char *hi
= &lo
[size
* (total_elems
- 1)];
172 /* Largest size needed for 32-bit int!!! */
173 stack_node stack
[STACK_SIZE
];
174 stack_node
*top
= stack
+ 1;
176 while (STACK_NOT_EMPTY
)
181 char *pivot
= pivot_buffer
;
183 /* Select median value from among LO, MID, and HI. Rearrange
184 LO and HI so the three values are sorted. This lowers the
185 probability of picking a pathological pivot value and
186 skips a comparison for both the LEFT_PTR and RIGHT_PTR. */
188 char *mid
= lo
+ size
* ((hi
- lo
) / size
>> 1);
190 if ((*cmp
) (less
, (void *) mid
, (void *) lo
))
191 SWAP (mid
, lo
, size
);
192 if ((*cmp
) (less
, (void *) hi
, (void *) mid
))
193 SWAP (mid
, hi
, size
);
196 if ((*cmp
) (less
, (void *) mid
, (void *) lo
))
197 SWAP (mid
, lo
, size
);
199 memcpy (pivot
, mid
, size
);
200 pivot
= pivot_buffer
;
202 left_ptr
= lo
+ size
;
203 right_ptr
= hi
- size
;
205 /* Here's the famous ``collapse the walls'' section of quicksort.
206 Gotta like those tight inner loops! They are the main reason
207 that this algorithm runs much faster than others. */
210 while ((*cmp
) (less
, (void *) left_ptr
, (void *) pivot
))
213 /* The comparison predicate may be buggy */
215 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
218 while ((*cmp
) (less
, (void *) pivot
, (void *) right_ptr
))
221 /* The comparison predicate may be buggy */
223 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
226 if (left_ptr
< right_ptr
)
228 SWAP (left_ptr
, right_ptr
, size
);
232 else if (left_ptr
== right_ptr
)
239 while (left_ptr
<= right_ptr
);
241 /* Set up pointers for next iteration. First determine whether
242 left and right partitions are below the threshold size. If so,
243 ignore one or both. Otherwise, push the larger partition's
244 bounds on the stack and continue sorting the smaller one. */
246 if ((size_t) (right_ptr
- lo
) <= max_thresh
)
248 if ((size_t) (hi
- left_ptr
) <= max_thresh
)
249 /* Ignore both small partitions. */
252 /* Ignore small left partition. */
255 else if ((size_t) (hi
- left_ptr
) <= max_thresh
)
256 /* Ignore small right partition. */
258 else if ((right_ptr
- lo
) > (hi
- left_ptr
))
260 /* Push larger left partition indices. */
261 PUSH (lo
, right_ptr
);
266 /* Push larger right partition indices. */
273 /* Once the BASE_PTR array is partially sorted by quicksort the rest
274 is completely sorted using insertion sort, since this is efficient
275 for partitions below MAX_THRESH size. BASE_PTR points to the beginning
276 of the array to sort, and END_PTR points at the very last element in
277 the array (*not* one beyond it!). */
280 char *const end_ptr
= &base_ptr
[size
* (total_elems
- 1)];
281 char *tmp_ptr
= base_ptr
;
282 char *thresh
= min (end_ptr
, base_ptr
+ max_thresh
);
283 register char *run_ptr
;
285 /* Find smallest element in first threshold and place it at the
286 array's beginning. This is the smallest array element,
287 and the operation speeds up insertion sort's inner loop. */
289 for (run_ptr
= tmp_ptr
+ size
; run_ptr
<= thresh
; run_ptr
+= size
)
290 if ((*cmp
) (less
, (void *) run_ptr
, (void *) tmp_ptr
))
293 if (tmp_ptr
!= base_ptr
)
294 SWAP (tmp_ptr
, base_ptr
, size
);
296 /* Insertion sort, running from left-hand-side up to right-hand-side. */
298 run_ptr
= base_ptr
+ size
;
299 while ((run_ptr
+= size
) <= end_ptr
)
301 tmp_ptr
= run_ptr
- size
;
302 while ((*cmp
) (less
, (void *) run_ptr
, (void *) tmp_ptr
))
305 /* The comparison predicate may be buggy */
306 if (tmp_ptr
< base_ptr
)
307 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
311 if (tmp_ptr
!= run_ptr
)
315 trav
= run_ptr
+ size
;
316 while (--trav
>= run_ptr
)
321 for (hi
= lo
= trav
; (lo
-= size
) >= tmp_ptr
; hi
= lo
)
331 /* comparison routines */
334 subr2less (SCM less
, const void *a
, const void *b
)
336 return SCM_NFALSEP (SCM_SUBRF (less
) (*(SCM
*) a
, *(SCM
*) b
));
340 lsubrless (SCM less
, const void *a
, const void *b
)
342 return SCM_NFALSEP (SCM_SUBRF (less
)
343 (scm_cons (*(SCM
*) a
,
344 scm_cons (*(SCM
*) b
, SCM_EOL
))));
348 closureless (SCM code
, const void *a
, const void *b
)
350 SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
351 scm_cons (*(SCM
*) a
,
352 scm_cons (*(SCM
*) b
, SCM_EOL
)),
354 /* Evaluate the closure body */
355 return !SCM_FALSEP (scm_eval_body (SCM_CLOSURE_BODY (code
), env
));
359 applyless (SCM less
, const void *a
, const void *b
)
361 return SCM_NFALSEP (scm_call_2 (less
, *(SCM
*) a
, *(SCM
*) b
));
365 scm_cmp_function (SCM p
)
367 switch (SCM_TYP7 (p
))
370 case scm_tc7_subr_2o
:
376 case scm_tcs_closures
:
381 } /* scm_cmp_function */
384 /* Question: Is there any need to make this a more general array sort?
385 It is probably enough to manage the vector type. */
386 /* endpos equal as for substring, i.e. endpos is not included. */
387 /* More natural with length? */
389 SCM_DEFINE (scm_restricted_vector_sort_x
, "restricted-vector-sort!", 4, 0, 0,
390 (SCM vec
, SCM less
, SCM startpos
, SCM endpos
),
391 "Sort the vector @var{vec}, using @var{less} for comparing\n"
392 "the vector elements. @var{startpos} and @var{endpos} delimit\n"
393 "the range of the vector which gets sorted. The return value\n"
395 #define FUNC_NAME s_scm_restricted_vector_sort_x
397 size_t vlen
, spos
, len
, size
= sizeof (SCM
);
400 SCM_VALIDATE_VECTOR (1, vec
);
401 SCM_VALIDATE_NIM (2, less
);
403 vp
= SCM_WRITABLE_VELTS (vec
); /* vector pointer */
404 vlen
= SCM_VECTOR_LENGTH (vec
);
406 SCM_VALIDATE_INUM_MIN_COPY (3, startpos
, 0, spos
);
407 SCM_ASSERT_RANGE (3, startpos
, spos
<= vlen
);
408 SCM_VALIDATE_INUM_RANGE (4, endpos
,0, vlen
+1);
409 len
= SCM_INUM (endpos
) - spos
;
411 quicksort (&vp
[spos
], len
, size
, scm_cmp_function (less
), less
);
413 return scm_return_first (SCM_UNSPECIFIED
, vec
);
418 /* (sorted? sequence less?)
419 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
420 * such that for all 1 <= i <= m,
421 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
422 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
423 (SCM items
, SCM less
),
424 "Return @code{#t} iff @var{items} is a list or a vector such that\n"
425 "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
426 "applied to all elements i - 1 and i")
427 #define FUNC_NAME s_scm_sorted_p
429 long len
, j
; /* list/vector length, temp j */
430 SCM item
, rest
; /* rest of items loop variable */
432 cmp_fun_t cmp
= scm_cmp_function (less
);
434 if (SCM_NULL_OR_NIL_P (items
))
437 SCM_VALIDATE_NIM (2, less
);
439 if (SCM_CONSP (items
))
441 len
= scm_ilength (items
); /* also checks that it's a pure list */
442 SCM_ASSERT_RANGE (1, items
, len
>= 0);
446 item
= SCM_CAR (items
);
447 rest
= SCM_CDR (items
);
451 if ((*cmp
) (less
, SCM_CARLOC(rest
), &item
))
455 item
= SCM_CAR (rest
);
456 rest
= SCM_CDR (rest
);
464 SCM_VALIDATE_VECTOR (1, items
);
466 vp
= SCM_VELTS (items
); /* vector pointer */
467 len
= SCM_VECTOR_LENGTH (items
);
471 if ((*cmp
) (less
, &vp
[1], vp
))
487 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
488 and returns a new list in which the elements of a and b have been stably
489 interleaved so that (sorted? (merge a b less?) less?).
490 Note: this does _not_ accept vectors. */
491 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
492 (SCM alist
, SCM blist
, SCM less
),
493 "Merge two already sorted lists into one.\n"
494 "Given two lists @var{alist} and @var{blist}, such that\n"
495 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
496 "return a new list in which the elements of @var{alist} and\n"
497 "@var{blist} have been stably interleaved so that\n"
498 "@code{(sorted? (merge alist blist less?) less?)}.\n"
499 "Note: this does _not_ accept vectors.")
500 #define FUNC_NAME s_scm_merge
502 long alen
, blen
; /* list lengths */
504 cmp_fun_t cmp
= scm_cmp_function (less
);
505 SCM_VALIDATE_NIM (3, less
);
507 if (SCM_NULL_OR_NIL_P (alist
))
509 else if (SCM_NULL_OR_NIL_P (blist
))
513 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
514 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
515 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
517 build
= scm_cons (SCM_CAR (blist
), SCM_EOL
);
518 blist
= SCM_CDR (blist
);
523 build
= scm_cons (SCM_CAR (alist
), SCM_EOL
);
524 alist
= SCM_CDR (alist
);
528 while ((alen
> 0) && (blen
> 0))
530 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
532 SCM_SETCDR (last
, scm_cons (SCM_CAR (blist
), SCM_EOL
));
533 blist
= SCM_CDR (blist
);
538 SCM_SETCDR (last
, scm_cons (SCM_CAR (alist
), SCM_EOL
));
539 alist
= SCM_CDR (alist
);
542 last
= SCM_CDR (last
);
544 if ((alen
> 0) && (blen
== 0))
545 SCM_SETCDR (last
, alist
);
546 else if ((alen
== 0) && (blen
> 0))
547 SCM_SETCDR (last
, blist
);
555 scm_merge_list_x (SCM alist
, SCM blist
,
556 long alen
, long blen
,
557 cmp_fun_t cmp
, SCM less
)
561 if (SCM_NULL_OR_NIL_P (alist
))
563 else if (SCM_NULL_OR_NIL_P (blist
))
567 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
570 blist
= SCM_CDR (blist
);
576 alist
= SCM_CDR (alist
);
580 while ((alen
> 0) && (blen
> 0))
582 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
584 SCM_SETCDR (last
, blist
);
585 blist
= SCM_CDR (blist
);
590 SCM_SETCDR (last
, alist
);
591 alist
= SCM_CDR (alist
);
594 last
= SCM_CDR (last
);
596 if ((alen
> 0) && (blen
== 0))
597 SCM_SETCDR (last
, alist
);
598 else if ((alen
== 0) && (blen
> 0))
599 SCM_SETCDR (last
, blist
);
602 } /* scm_merge_list_x */
604 SCM_DEFINE (scm_merge_x
, "merge!", 3, 0, 0,
605 (SCM alist
, SCM blist
, SCM less
),
606 "Takes two lists @var{alist} and @var{blist} such that\n"
607 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
608 "returns a new list in which the elements of @var{alist} and\n"
609 "@var{blist} have been stably interleaved so that\n"
610 " @code{(sorted? (merge alist blist less?) less?)}.\n"
611 "This is the destructive variant of @code{merge}\n"
612 "Note: this does _not_ accept vectors.")
613 #define FUNC_NAME s_scm_merge_x
615 long alen
, blen
; /* list lengths */
617 SCM_VALIDATE_NIM (3, less
);
618 if (SCM_NULL_OR_NIL_P (alist
))
620 else if (SCM_NULL_OR_NIL_P (blist
))
624 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
625 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
626 return scm_merge_list_x (alist
, blist
,
628 scm_cmp_function (less
),
634 /* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
635 The algorithm is stable. We also tried to use the algorithm used by
636 scsh's merge-sort but that algorithm showed to not be stable, even
637 though it claimed to be.
640 scm_merge_list_step (SCM
* seq
,
650 a
= scm_merge_list_step (seq
, cmp
, less
, mid
);
651 b
= scm_merge_list_step (seq
, cmp
, less
, n
- mid
);
652 return scm_merge_list_x (a
, b
, mid
, n
- mid
, cmp
, less
);
657 SCM rest
= SCM_CDR (*seq
);
658 SCM x
= SCM_CAR (*seq
);
659 SCM y
= SCM_CAR (SCM_CDR (*seq
));
660 *seq
= SCM_CDR (rest
);
661 SCM_SETCDR (rest
, SCM_EOL
);
662 if ((*cmp
) (less
, &y
, &x
))
665 SCM_SETCAR (rest
, x
);
673 SCM_SETCDR (p
, SCM_EOL
);
678 } /* scm_merge_list_step */
681 /* scm_sort_x manages lists and vectors, not stable sort */
682 SCM_DEFINE (scm_sort_x
, "sort!", 2, 0, 0,
683 (SCM items
, SCM less
),
684 "Sort the sequence @var{items}, which may be a list or a\n"
685 "vector. @var{less} is used for comparing the sequence\n"
686 "elements. The sorting is destructive, that means that the\n"
687 "input sequence is modified to produce the sorted result.\n"
688 "This is not a stable sort.")
689 #define FUNC_NAME s_scm_sort_x
691 long len
; /* list/vector length */
692 if (SCM_NULL_OR_NIL_P (items
))
695 SCM_VALIDATE_NIM (2, less
);
697 if (SCM_CONSP (items
))
699 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
700 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
702 else if (SCM_VECTORP (items
))
704 len
= SCM_VECTOR_LENGTH (items
);
705 scm_restricted_vector_sort_x (items
,
712 SCM_WRONG_TYPE_ARG (1, items
);
716 /* scm_sort manages lists and vectors, not stable sort */
718 SCM_DEFINE (scm_sort
, "sort", 2, 0, 0,
719 (SCM items
, SCM less
),
720 "Sort the sequence @var{items}, which may be a list or a\n"
721 "vector. @var{less} is used for comparing the sequence\n"
722 "elements. This is not a stable sort.")
723 #define FUNC_NAME s_scm_sort
725 if (SCM_NULL_OR_NIL_P (items
))
728 SCM_VALIDATE_NIM (2, less
);
729 if (SCM_CONSP (items
))
733 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
734 items
= scm_list_copy (items
);
735 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
738 /* support ordinary vectors even if arrays not available? */
739 else if (SCM_VECTORP (items
))
741 long len
= SCM_VECTOR_LENGTH (items
);
742 SCM sortvec
= scm_make_uve (len
, scm_array_prototype (items
));
744 scm_array_copy_x (items
, sortvec
);
745 scm_restricted_vector_sort_x (sortvec
,
753 SCM_WRONG_TYPE_ARG (1, items
);
758 scm_merge_vector_x (SCM vec
,
766 long it
; /* Index for temp vector */
767 long i1
= low
; /* Index for lower vector segment */
768 long i2
= mid
+ 1; /* Index for upper vector segment */
770 /* Copy while both segments contain more characters */
771 for (it
= low
; (i1
<= mid
) && (i2
<= high
); ++it
)
774 Every call of LESS might invoke GC. For full correctness, we
775 should reset the generation of vecbase and tempbase between
779 register SCM
*vp
= SCM_WRITABLE_VELTS(vec
);
781 if ((*cmp
) (less
, &vp
[i2
], &vp
[i1
]))
788 register SCM
*vp
= SCM_WRITABLE_VELTS(vec
);
790 /* Copy while first segment contains more characters */
792 temp
[it
++] = vp
[i1
++];
794 /* Copy while second segment contains more characters */
796 temp
[it
++] = vp
[i2
++];
798 /* Copy back from temp to vp */
799 for (it
= low
; it
<= high
; ++it
)
802 } /* scm_merge_vector_x */
805 scm_merge_vector_step (SCM vp
,
814 long mid
= (low
+ high
) / 2;
815 scm_merge_vector_step (vp
, temp
, cmp
, less
, low
, mid
);
816 scm_merge_vector_step (vp
, temp
, cmp
, less
, mid
+1, high
);
817 scm_merge_vector_x (vp
, temp
, cmp
, less
, low
, mid
, high
);
819 } /* scm_merge_vector_step */
822 /* stable-sort! manages lists and vectors */
824 SCM_DEFINE (scm_stable_sort_x
, "stable-sort!", 2, 0, 0,
825 (SCM items
, SCM less
),
826 "Sort the sequence @var{items}, which may be a list or a\n"
827 "vector. @var{less} is used for comparing the sequence elements.\n"
828 "The sorting is destructive, that means that the input sequence\n"
829 "is modified to produce the sorted result.\n"
830 "This is a stable sort.")
831 #define FUNC_NAME s_scm_stable_sort_x
833 long len
; /* list/vector length */
835 if (SCM_NULL_OR_NIL_P (items
))
838 SCM_VALIDATE_NIM (2, less
);
839 if (SCM_CONSP (items
))
841 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
842 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
844 else if (SCM_VECTORP (items
))
847 len
= SCM_VECTOR_LENGTH (items
);
850 the following array does not contain any new references to
851 SCM objects, so we can get away with allocing it on the heap.
853 temp
= scm_malloc (len
* sizeof(SCM
));
855 scm_merge_vector_step (items
,
857 scm_cmp_function (less
),
865 SCM_WRONG_TYPE_ARG (1, items
);
869 /* stable_sort manages lists and vectors */
870 SCM_DEFINE (scm_stable_sort
, "stable-sort", 2, 0, 0,
871 (SCM items
, SCM less
),
872 "Sort the sequence @var{items}, which may be a list or a\n"
873 "vector. @var{less} is used for comparing the sequence elements.\n"
874 "This is a stable sort.")
875 #define FUNC_NAME s_scm_stable_sort
878 if (SCM_NULL_OR_NIL_P (items
))
881 SCM_VALIDATE_NIM (2, less
);
882 if (SCM_CONSP (items
))
884 long len
; /* list/vector length */
885 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
886 items
= scm_list_copy (items
);
887 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
890 /* support ordinary vectors even if arrays not available? */
891 else if (SCM_VECTORP (items
))
893 long len
= SCM_VECTOR_LENGTH (items
);
894 SCM
*temp
= scm_malloc (len
* sizeof (SCM
));
895 SCM retvec
= scm_make_uve (len
, scm_array_prototype (items
));
896 scm_array_copy_x (items
, retvec
);
898 scm_merge_vector_step (retvec
,
900 scm_cmp_function (less
),
909 SCM_WRONG_TYPE_ARG (1, items
);
914 SCM_DEFINE (scm_sort_list_x
, "sort-list!", 2, 0, 0,
915 (SCM items
, SCM less
),
916 "Sort the list @var{items}, using @var{less} for comparing the\n"
917 "list elements. The sorting is destructive, that means that the\n"
918 "input list is modified to produce the sorted result.\n"
919 "This is a stable sort.")
920 #define FUNC_NAME s_scm_sort_list_x
923 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
924 SCM_VALIDATE_NIM (2, less
);
925 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
930 SCM_DEFINE (scm_sort_list
, "sort-list", 2, 0, 0,
931 (SCM items
, SCM less
),
932 "Sort the list @var{items}, using @var{less} for comparing the\n"
933 "list elements. This is a stable sort.")
934 #define FUNC_NAME s_scm_sort_list
937 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
938 SCM_VALIDATE_NIM (2, less
);
939 items
= scm_list_copy (items
);
940 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
947 #include "libguile/sort.x"
949 scm_add_feature ("sort");