1 /* Copyright (C) 1999,2000,2001,2002 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. */
43 /* Written in December 1998 by Roland Orre <orre@nada.kth.se>
44 * This implements the same sort interface as slib/sort.scm
45 * for lists and vectors where slib defines:
46 * sorted?, merge, merge!, sort, sort!
47 * For scsh compatibility sort-list and sort-list! are also defined.
48 * In cases where a stable-sort is required use stable-sort or
49 * stable-sort!. An additional feature is
50 * (restricted-vector-sort! vector less? startpos endpos)
51 * which allows you to sort part of a vector.
52 * Thanks to Aubrey Jaffer for the slib/sort.scm library.
53 * Thanks to Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
54 * for the merge sort inspiration.
55 * Thanks to Douglas C. Schmidt (schmidt@ics.uci.edu) for the
59 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
60 #include "libguile/scmconfig.h"
62 /* AIX requires this to be the first thing in the file. The #pragma
63 directive is indented so pre-ANSI compilers will ignore it, rather
72 # ifndef alloca /* predefined by HP cc +Olibcalls */
80 #include "libguile/_scm.h"
82 #include "libguile/eval.h"
83 #include "libguile/unif.h"
84 #include "libguile/ramap.h"
85 #include "libguile/alist.h"
86 #include "libguile/feature.h"
87 #include "libguile/root.h"
88 #include "libguile/vectors.h"
89 #include "libguile/lang.h"
91 #include "libguile/validate.h"
92 #include "libguile/sort.h"
94 /* The routine quicksort was extracted from the GNU C Library qsort.c
95 written by Douglas C. Schmidt (schmidt@ics.uci.edu)
96 and adapted to guile by adding an extra pointer less
97 to quicksort by Roland Orre <orre@nada.kth.se>.
99 The reason to do this instead of using the library function qsort
100 was to avoid dependency of the ANSI-C extensions for local functions
101 and also to avoid obscure pool based solutions.
103 This sorting routine is not much more efficient than the stable
104 version but doesn't consume extra memory.
107 /* Byte-wise swap two items of size SIZE. */
108 #define SWAP(a, b, size) \
111 register size_t __size = (size); \
112 register char *__a = (a), *__b = (b); \
118 } while (--__size > 0); \
121 /* Discontinue quicksort algorithm when partition gets below this size.
122 This particular magic number was chosen to work best on a Sun 4/260. */
125 /* Stack node declarations used to store unfulfilled partition obligations. */
133 /* The next 4 #defines implement a very fast in-line stack abstraction. */
134 #define STACK_SIZE (8 * sizeof(unsigned long int))
135 #define PUSH(low, high) ((void) ((top->lo = (low)), (top->hi = (high)), ++top))
136 #define POP(low, high) ((void) (--top, (low = top->lo), (high = top->hi)))
137 #define STACK_NOT_EMPTY (stack < top)
140 /* Order size using quicksort. This implementation incorporates
141 four optimizations discussed in Sedgewick:
143 1. Non-recursive, using an explicit stack of pointer that store the
144 next array partition to sort. To save time, this maximum amount
145 of space required to store an array of MAX_INT is allocated on the
146 stack. Assuming a 32-bit integer, this needs only 32 *
147 sizeof(stack_node) == 136 bits. Pretty cheap, actually.
149 2. Chose the pivot element using a median-of-three decision tree.
150 This reduces the probability of selecting a bad pivot value and
151 eliminates certain extraneous comparisons.
153 3. Only quicksorts TOTAL_ELEMS / MAX_THRESH partitions, leaving
154 insertion sort to order the MAX_THRESH items within each partition.
155 This is a big win, since insertion sort is faster for small, mostly
156 sorted array segments.
158 4. The larger of the two sub-partitions is always pushed onto the
159 stack first, with the algorithm then concentrating on the
160 smaller partition. This *guarantees* no more than log (n)
161 stack size is needed (actually O(1) in this case)! */
163 typedef int (*cmp_fun_t
) (SCM less
,
167 static const char s_buggy_less
[] = "buggy less predicate used when sorting";
170 quicksort (void *const pbase
,
176 register char *base_ptr
= (char *) pbase
;
178 /* Allocating SIZE bytes for a pivot buffer facilitates a better
179 algorithm below since we can do comparisons directly on the pivot. */
180 char *pivot_buffer
= (char *) alloca (size
);
181 const size_t max_thresh
= MAX_THRESH
* size
;
183 if (total_elems
== 0)
184 /* Avoid lossage with unsigned arithmetic below. */
187 if (total_elems
> MAX_THRESH
)
190 char *hi
= &lo
[size
* (total_elems
- 1)];
191 /* Largest size needed for 32-bit int!!! */
192 stack_node stack
[STACK_SIZE
];
193 stack_node
*top
= stack
+ 1;
195 while (STACK_NOT_EMPTY
)
200 char *pivot
= pivot_buffer
;
202 /* Select median value from among LO, MID, and HI. Rearrange
203 LO and HI so the three values are sorted. This lowers the
204 probability of picking a pathological pivot value and
205 skips a comparison for both the LEFT_PTR and RIGHT_PTR. */
207 char *mid
= lo
+ size
* ((hi
- lo
) / size
>> 1);
209 if ((*cmp
) (less
, (void *) mid
, (void *) lo
))
210 SWAP (mid
, lo
, size
);
211 if ((*cmp
) (less
, (void *) hi
, (void *) mid
))
212 SWAP (mid
, hi
, size
);
215 if ((*cmp
) (less
, (void *) mid
, (void *) lo
))
216 SWAP (mid
, lo
, size
);
218 memcpy (pivot
, mid
, size
);
219 pivot
= pivot_buffer
;
221 left_ptr
= lo
+ size
;
222 right_ptr
= hi
- size
;
224 /* Here's the famous ``collapse the walls'' section of quicksort.
225 Gotta like those tight inner loops! They are the main reason
226 that this algorithm runs much faster than others. */
229 while ((*cmp
) (less
, (void *) left_ptr
, (void *) pivot
))
232 /* The comparison predicate may be buggy */
234 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
237 while ((*cmp
) (less
, (void *) pivot
, (void *) right_ptr
))
240 /* The comparison predicate may be buggy */
242 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
245 if (left_ptr
< right_ptr
)
247 SWAP (left_ptr
, right_ptr
, size
);
251 else if (left_ptr
== right_ptr
)
258 while (left_ptr
<= right_ptr
);
260 /* Set up pointers for next iteration. First determine whether
261 left and right partitions are below the threshold size. If so,
262 ignore one or both. Otherwise, push the larger partition's
263 bounds on the stack and continue sorting the smaller one. */
265 if ((size_t) (right_ptr
- lo
) <= max_thresh
)
267 if ((size_t) (hi
- left_ptr
) <= max_thresh
)
268 /* Ignore both small partitions. */
271 /* Ignore small left partition. */
274 else if ((size_t) (hi
- left_ptr
) <= max_thresh
)
275 /* Ignore small right partition. */
277 else if ((right_ptr
- lo
) > (hi
- left_ptr
))
279 /* Push larger left partition indices. */
280 PUSH (lo
, right_ptr
);
285 /* Push larger right partition indices. */
292 /* Once the BASE_PTR array is partially sorted by quicksort the rest
293 is completely sorted using insertion sort, since this is efficient
294 for partitions below MAX_THRESH size. BASE_PTR points to the beginning
295 of the array to sort, and END_PTR points at the very last element in
296 the array (*not* one beyond it!). */
299 char *const end_ptr
= &base_ptr
[size
* (total_elems
- 1)];
300 char *tmp_ptr
= base_ptr
;
301 char *thresh
= min (end_ptr
, base_ptr
+ max_thresh
);
302 register char *run_ptr
;
304 /* Find smallest element in first threshold and place it at the
305 array's beginning. This is the smallest array element,
306 and the operation speeds up insertion sort's inner loop. */
308 for (run_ptr
= tmp_ptr
+ size
; run_ptr
<= thresh
; run_ptr
+= size
)
309 if ((*cmp
) (less
, (void *) run_ptr
, (void *) tmp_ptr
))
312 if (tmp_ptr
!= base_ptr
)
313 SWAP (tmp_ptr
, base_ptr
, size
);
315 /* Insertion sort, running from left-hand-side up to right-hand-side. */
317 run_ptr
= base_ptr
+ size
;
318 while ((run_ptr
+= size
) <= end_ptr
)
320 tmp_ptr
= run_ptr
- size
;
321 while ((*cmp
) (less
, (void *) run_ptr
, (void *) tmp_ptr
))
324 /* The comparison predicate may be buggy */
325 if (tmp_ptr
< base_ptr
)
326 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
330 if (tmp_ptr
!= run_ptr
)
334 trav
= run_ptr
+ size
;
335 while (--trav
>= run_ptr
)
340 for (hi
= lo
= trav
; (lo
-= size
) >= tmp_ptr
; hi
= lo
)
350 /* comparison routines */
353 subr2less (SCM less
, const void *a
, const void *b
)
355 return SCM_NFALSEP (SCM_SUBRF (less
) (*(SCM
*) a
, *(SCM
*) b
));
359 lsubrless (SCM less
, const void *a
, const void *b
)
361 return SCM_NFALSEP (SCM_SUBRF (less
)
362 (scm_cons (*(SCM
*) a
,
363 scm_cons (*(SCM
*) b
, SCM_EOL
))));
367 closureless (SCM code
, const void *a
, const void *b
)
369 SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code
),
370 scm_cons (*(SCM
*) a
,
371 scm_cons (*(SCM
*) b
, SCM_EOL
)),
373 /* Evaluate the closure body */
374 return !SCM_FALSEP (scm_eval_body (SCM_CLOSURE_BODY (code
), env
));
378 applyless (SCM less
, const void *a
, const void *b
)
380 return SCM_NFALSEP (scm_call_2 (less
, *(SCM
*) a
, *(SCM
*) b
));
384 scm_cmp_function (SCM p
)
386 switch (SCM_TYP7 (p
))
389 case scm_tc7_subr_2o
:
395 case scm_tcs_closures
:
400 } /* scm_cmp_function */
403 /* Question: Is there any need to make this a more general array sort?
404 It is probably enough to manage the vector type. */
405 /* endpos equal as for substring, i.e. endpos is not included. */
406 /* More natural with length? */
408 SCM_DEFINE (scm_restricted_vector_sort_x
, "restricted-vector-sort!", 4, 0, 0,
409 (SCM vec
, SCM less
, SCM startpos
, SCM endpos
),
410 "Sort the vector @var{vec}, using @var{less} for comparing\n"
411 "the vector elements. @var{startpos} and @var{endpos} delimit\n"
412 "the range of the vector which gets sorted. The return value\n"
414 #define FUNC_NAME s_scm_restricted_vector_sort_x
416 size_t vlen
, spos
, len
, size
= sizeof (SCM
);
419 SCM_VALIDATE_VECTOR (1, vec
);
420 SCM_VALIDATE_NIM (2, less
);
422 vp
= SCM_WRITABLE_VELTS (vec
); /* vector pointer */
423 vlen
= SCM_VECTOR_LENGTH (vec
);
425 SCM_VALIDATE_INUM_MIN_COPY (3, startpos
, 0, spos
);
426 SCM_ASSERT_RANGE (3, startpos
, spos
<= vlen
);
427 SCM_VALIDATE_INUM_RANGE (4, endpos
,0, vlen
+1);
428 len
= SCM_INUM (endpos
) - spos
;
430 quicksort (&vp
[spos
], len
, size
, scm_cmp_function (less
), less
);
432 return scm_return_first (SCM_UNSPECIFIED
, vec
);
437 /* (sorted? sequence less?)
438 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
439 * such that for all 1 <= i <= m,
440 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
441 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
442 (SCM items
, SCM less
),
443 "Return @code{#t} iff @var{items} is a list or a vector such that\n"
444 "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
445 "applied to all elements i - 1 and i")
446 #define FUNC_NAME s_scm_sorted_p
448 long len
, j
; /* list/vector length, temp j */
449 SCM item
, rest
; /* rest of items loop variable */
451 cmp_fun_t cmp
= scm_cmp_function (less
);
453 if (SCM_NULL_OR_NIL_P (items
))
456 SCM_VALIDATE_NIM (2, less
);
458 if (SCM_CONSP (items
))
460 len
= scm_ilength (items
); /* also checks that it's a pure list */
461 SCM_ASSERT_RANGE (1, items
, len
>= 0);
465 item
= SCM_CAR (items
);
466 rest
= SCM_CDR (items
);
470 if ((*cmp
) (less
, SCM_CARLOC(rest
), &item
))
474 item
= SCM_CAR (rest
);
475 rest
= SCM_CDR (rest
);
483 SCM_VALIDATE_VECTOR (1, items
);
485 vp
= SCM_VELTS (items
); /* vector pointer */
486 len
= SCM_VECTOR_LENGTH (items
);
490 if ((*cmp
) (less
, &vp
[1], vp
))
506 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
507 and returns a new list in which the elements of a and b have been stably
508 interleaved so that (sorted? (merge a b less?) less?).
509 Note: this does _not_ accept vectors. */
510 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
511 (SCM alist
, SCM blist
, SCM less
),
512 "Merge two already sorted lists into one.\n"
513 "Given two lists @var{alist} and @var{blist}, such that\n"
514 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
515 "return a new list in which the elements of @var{alist} and\n"
516 "@var{blist} have been stably interleaved so that\n"
517 "@code{(sorted? (merge alist blist less?) less?)}.\n"
518 "Note: this does _not_ accept vectors.")
519 #define FUNC_NAME s_scm_merge
521 long alen
, blen
; /* list lengths */
523 cmp_fun_t cmp
= scm_cmp_function (less
);
524 SCM_VALIDATE_NIM (3, less
);
526 if (SCM_NULL_OR_NIL_P (alist
))
528 else if (SCM_NULL_OR_NIL_P (blist
))
532 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
533 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
534 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
536 build
= scm_cons (SCM_CAR (blist
), SCM_EOL
);
537 blist
= SCM_CDR (blist
);
542 build
= scm_cons (SCM_CAR (alist
), SCM_EOL
);
543 alist
= SCM_CDR (alist
);
547 while ((alen
> 0) && (blen
> 0))
549 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
551 SCM_SETCDR (last
, scm_cons (SCM_CAR (blist
), SCM_EOL
));
552 blist
= SCM_CDR (blist
);
557 SCM_SETCDR (last
, scm_cons (SCM_CAR (alist
), SCM_EOL
));
558 alist
= SCM_CDR (alist
);
561 last
= SCM_CDR (last
);
563 if ((alen
> 0) && (blen
== 0))
564 SCM_SETCDR (last
, alist
);
565 else if ((alen
== 0) && (blen
> 0))
566 SCM_SETCDR (last
, blist
);
574 scm_merge_list_x (SCM alist
, SCM blist
,
575 long alen
, long blen
,
576 cmp_fun_t cmp
, SCM less
)
580 if (SCM_NULL_OR_NIL_P (alist
))
582 else if (SCM_NULL_OR_NIL_P (blist
))
586 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
589 blist
= SCM_CDR (blist
);
595 alist
= SCM_CDR (alist
);
599 while ((alen
> 0) && (blen
> 0))
601 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
603 SCM_SETCDR (last
, blist
);
604 blist
= SCM_CDR (blist
);
609 SCM_SETCDR (last
, alist
);
610 alist
= SCM_CDR (alist
);
613 last
= SCM_CDR (last
);
615 if ((alen
> 0) && (blen
== 0))
616 SCM_SETCDR (last
, alist
);
617 else if ((alen
== 0) && (blen
> 0))
618 SCM_SETCDR (last
, blist
);
621 } /* scm_merge_list_x */
623 SCM_DEFINE (scm_merge_x
, "merge!", 3, 0, 0,
624 (SCM alist
, SCM blist
, SCM less
),
625 "Takes two lists @var{alist} and @var{blist} such that\n"
626 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
627 "returns a new list in which the elements of @var{alist} and\n"
628 "@var{blist} have been stably interleaved so that\n"
629 " @code{(sorted? (merge alist blist less?) less?)}.\n"
630 "This is the destructive variant of @code{merge}\n"
631 "Note: this does _not_ accept vectors.")
632 #define FUNC_NAME s_scm_merge_x
634 long alen
, blen
; /* list lengths */
636 SCM_VALIDATE_NIM (3, less
);
637 if (SCM_NULL_OR_NIL_P (alist
))
639 else if (SCM_NULL_OR_NIL_P (blist
))
643 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
644 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
645 return scm_merge_list_x (alist
, blist
,
647 scm_cmp_function (less
),
653 /* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
654 The algorithm is stable. We also tried to use the algorithm used by
655 scsh's merge-sort but that algorithm showed to not be stable, even
656 though it claimed to be.
659 scm_merge_list_step (SCM
* seq
,
669 a
= scm_merge_list_step (seq
, cmp
, less
, mid
);
670 b
= scm_merge_list_step (seq
, cmp
, less
, n
- mid
);
671 return scm_merge_list_x (a
, b
, mid
, n
- mid
, cmp
, less
);
676 SCM rest
= SCM_CDR (*seq
);
677 SCM x
= SCM_CAR (*seq
);
678 SCM y
= SCM_CAR (SCM_CDR (*seq
));
679 *seq
= SCM_CDR (rest
);
680 SCM_SETCDR (rest
, SCM_EOL
);
681 if ((*cmp
) (less
, &y
, &x
))
684 SCM_SETCAR (rest
, x
);
692 SCM_SETCDR (p
, SCM_EOL
);
697 } /* scm_merge_list_step */
700 /* scm_sort_x manages lists and vectors, not stable sort */
701 SCM_DEFINE (scm_sort_x
, "sort!", 2, 0, 0,
702 (SCM items
, SCM less
),
703 "Sort the sequence @var{items}, which may be a list or a\n"
704 "vector. @var{less} is used for comparing the sequence\n"
705 "elements. The sorting is destructive, that means that the\n"
706 "input sequence is modified to produce the sorted result.\n"
707 "This is not a stable sort.")
708 #define FUNC_NAME s_scm_sort_x
710 long len
; /* list/vector length */
711 if (SCM_NULL_OR_NIL_P (items
))
714 SCM_VALIDATE_NIM (2, less
);
716 if (SCM_CONSP (items
))
718 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
719 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
721 else if (SCM_VECTORP (items
))
723 len
= SCM_VECTOR_LENGTH (items
);
724 scm_restricted_vector_sort_x (items
,
731 SCM_WRONG_TYPE_ARG (1, items
);
735 /* scm_sort manages lists and vectors, not stable sort */
737 SCM_DEFINE (scm_sort
, "sort", 2, 0, 0,
738 (SCM items
, SCM less
),
739 "Sort the sequence @var{items}, which may be a list or a\n"
740 "vector. @var{less} is used for comparing the sequence\n"
741 "elements. This is not a stable sort.")
742 #define FUNC_NAME s_scm_sort
744 if (SCM_NULL_OR_NIL_P (items
))
747 SCM_VALIDATE_NIM (2, less
);
748 if (SCM_CONSP (items
))
752 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
753 items
= scm_list_copy (items
);
754 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
757 /* support ordinary vectors even if arrays not available? */
758 else if (SCM_VECTORP (items
))
760 long len
= SCM_VECTOR_LENGTH (items
);
761 SCM sortvec
= scm_make_uve (len
, scm_array_prototype (items
));
763 scm_array_copy_x (items
, sortvec
);
764 scm_restricted_vector_sort_x (sortvec
,
772 SCM_WRONG_TYPE_ARG (1, items
);
777 scm_merge_vector_x (SCM vec
,
785 long it
; /* Index for temp vector */
786 long i1
= low
; /* Index for lower vector segment */
787 long i2
= mid
+ 1; /* Index for upper vector segment */
789 /* Copy while both segments contain more characters */
790 for (it
= low
; (i1
<= mid
) && (i2
<= high
); ++it
)
793 Every call of LESS might invoke GC. For full correctness, we
794 should reset the generation of vecbase and tempbase between
798 register SCM
*vp
= SCM_WRITABLE_VELTS(vec
);
800 if ((*cmp
) (less
, &vp
[i2
], &vp
[i1
]))
807 register SCM
*vp
= SCM_WRITABLE_VELTS(vec
);
809 /* Copy while first segment contains more characters */
811 temp
[it
++] = vp
[i1
++];
813 /* Copy while second segment contains more characters */
815 temp
[it
++] = vp
[i2
++];
817 /* Copy back from temp to vp */
818 for (it
= low
; it
<= high
; ++it
)
821 } /* scm_merge_vector_x */
824 scm_merge_vector_step (SCM vp
,
833 long mid
= (low
+ high
) / 2;
834 scm_merge_vector_step (vp
, temp
, cmp
, less
, low
, mid
);
835 scm_merge_vector_step (vp
, temp
, cmp
, less
, mid
+1, high
);
836 scm_merge_vector_x (vp
, temp
, cmp
, less
, low
, mid
, high
);
838 } /* scm_merge_vector_step */
841 /* stable-sort! manages lists and vectors */
843 SCM_DEFINE (scm_stable_sort_x
, "stable-sort!", 2, 0, 0,
844 (SCM items
, SCM less
),
845 "Sort the sequence @var{items}, which may be a list or a\n"
846 "vector. @var{less} is used for comparing the sequence elements.\n"
847 "The sorting is destructive, that means that the input sequence\n"
848 "is modified to produce the sorted result.\n"
849 "This is a stable sort.")
850 #define FUNC_NAME s_scm_stable_sort_x
852 long len
; /* list/vector length */
854 if (SCM_NULL_OR_NIL_P (items
))
857 SCM_VALIDATE_NIM (2, less
);
858 if (SCM_CONSP (items
))
860 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
861 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
863 else if (SCM_VECTORP (items
))
866 len
= SCM_VECTOR_LENGTH (items
);
869 the following array does not contain any new references to
870 SCM objects, so we can get away with allocing it on the heap.
872 temp
= scm_malloc (len
* sizeof(SCM
));
874 scm_merge_vector_step (items
,
876 scm_cmp_function (less
),
884 SCM_WRONG_TYPE_ARG (1, items
);
888 /* stable_sort manages lists and vectors */
889 SCM_DEFINE (scm_stable_sort
, "stable-sort", 2, 0, 0,
890 (SCM items
, SCM less
),
891 "Sort the sequence @var{items}, which may be a list or a\n"
892 "vector. @var{less} is used for comparing the sequence elements.\n"
893 "This is a stable sort.")
894 #define FUNC_NAME s_scm_stable_sort
897 if (SCM_NULL_OR_NIL_P (items
))
900 SCM_VALIDATE_NIM (2, less
);
901 if (SCM_CONSP (items
))
903 long len
; /* list/vector length */
904 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
905 items
= scm_list_copy (items
);
906 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
909 /* support ordinary vectors even if arrays not available? */
910 else if (SCM_VECTORP (items
))
912 long len
= SCM_VECTOR_LENGTH (items
);
913 SCM
*temp
= scm_malloc (len
* sizeof (SCM
));
914 SCM retvec
= scm_make_uve (len
, scm_array_prototype (items
));
915 scm_array_copy_x (items
, retvec
);
917 scm_merge_vector_step (retvec
,
919 scm_cmp_function (less
),
928 SCM_WRONG_TYPE_ARG (1, items
);
933 SCM_DEFINE (scm_sort_list_x
, "sort-list!", 2, 0, 0,
934 (SCM items
, SCM less
),
935 "Sort the list @var{items}, using @var{less} for comparing the\n"
936 "list elements. The sorting is destructive, that means that the\n"
937 "input list is modified to produce the sorted result.\n"
938 "This is a stable sort.")
939 #define FUNC_NAME s_scm_sort_list_x
942 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
943 SCM_VALIDATE_NIM (2, less
);
944 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
949 SCM_DEFINE (scm_sort_list
, "sort-list", 2, 0, 0,
950 (SCM items
, SCM less
),
951 "Sort the list @var{items}, using @var{less} for comparing the\n"
952 "list elements. This is a stable sort.")
953 #define FUNC_NAME s_scm_sort_list
956 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
957 SCM_VALIDATE_NIM (2, less
);
958 items
= scm_list_copy (items
);
959 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
966 #include "libguile/sort.x"
968 scm_add_feature ("sort");