1 /* Copyright (C) 1999, 2000 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/vectors.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 subr2oless (SCM less
, const void *a
, const void *b
)
361 return SCM_NFALSEP (SCM_SUBRF (less
) (*(SCM
*) a
,
367 lsubrless (SCM less
, const void *a
, const void *b
)
369 return SCM_NFALSEP (SCM_SUBRF (less
)
370 (scm_cons (*(SCM
*) a
,
371 scm_cons (*(SCM
*) b
, SCM_EOL
))));
375 closureless (SCM code
, const void *a
, const void *b
)
377 SCM env
= SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code
)),
378 scm_cons (*(SCM
*) a
,
379 scm_cons (*(SCM
*) b
, SCM_EOL
)),
381 /* Evaluate the closure body */
382 return SCM_NFALSEP (scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
));
386 applyless (SCM less
, const void *a
, const void *b
)
388 return SCM_NFALSEP (scm_apply (less
,
389 scm_cons (*(SCM
*) a
,
390 scm_cons (*(SCM
*) b
, SCM_EOL
)),
395 scm_cmp_function (SCM p
)
397 switch (SCM_TYP7 (p
))
403 case scm_tc7_subr_2o
:
407 case scm_tcs_closures
:
412 } /* scm_cmp_function */
415 /* Question: Is there any need to make this a more general array sort?
416 It is probably enough to manage the vector type. */
417 /* endpos equal as for substring, i.e. endpos is not included. */
418 /* More natural with length? */
420 SCM_DEFINE (scm_restricted_vector_sort_x
, "restricted-vector-sort!", 4, 0, 0,
421 (SCM vec
, SCM less
, SCM startpos
, SCM endpos
),
422 "Sort the vector @var{vec}, using @var{less} for comparing\n"
423 "the vector elements. @var{startpos} and @var{endpos} delimit\n"
424 "the range of the vector which gets sorted. The return value\n"
426 #define FUNC_NAME s_scm_restricted_vector_sort_x
428 size_t vlen
, spos
, len
, size
= sizeof (SCM
);
431 SCM_VALIDATE_VECTOR (1,vec
);
432 SCM_VALIDATE_NIM (2,less
);
434 vp
= SCM_VELTS (vec
); /* vector pointer */
435 vlen
= SCM_VECTOR_LENGTH (vec
);
437 SCM_VALIDATE_INUM_COPY (3,startpos
,spos
);
438 SCM_ASSERT_RANGE (3,startpos
,(spos
>= 0) && (spos
<= vlen
));
439 SCM_VALIDATE_INUM_RANGE (4,endpos
,0,vlen
+1);
440 len
= SCM_INUM (endpos
) - spos
;
442 quicksort (&vp
[spos
], len
, size
, scm_cmp_function (less
), less
);
443 return SCM_UNSPECIFIED
;
448 /* (sorted? sequence less?)
449 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
450 * such that for all 1 <= i <= m,
451 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
452 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
453 (SCM items
, SCM less
),
454 "Return @code{#t} iff @var{items} is a list or a vector such that\n"
455 "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
456 "applied to all elements i - 1 and i")
457 #define FUNC_NAME s_scm_sorted_p
459 long len
, j
; /* list/vector length, temp j */
460 SCM item
, rest
; /* rest of items loop variable */
462 cmp_fun_t cmp
= scm_cmp_function (less
);
464 if (SCM_NULLP (items
))
467 SCM_VALIDATE_NIM (2,less
);
469 if (SCM_CONSP (items
))
471 len
= scm_ilength (items
); /* also checks that it's a pure list */
472 SCM_ASSERT_RANGE (1,items
,len
>= 0);
476 item
= SCM_CAR (items
);
477 rest
= SCM_CDR (items
);
481 if ((*cmp
) (less
, SCM_CARLOC(rest
), &item
))
485 item
= SCM_CAR (rest
);
486 rest
= SCM_CDR (rest
);
494 SCM_VALIDATE_VECTOR (1, items
);
496 vp
= SCM_VELTS (items
); /* vector pointer */
497 len
= SCM_VECTOR_LENGTH (items
);
501 if ((*cmp
) (less
, &vp
[1], vp
))
517 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
518 and returns a new list in which the elements of a and b have been stably
519 interleaved so that (sorted? (merge a b less?) less?).
520 Note: this does _not_ accept vectors. */
521 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
522 (SCM alist
, SCM blist
, SCM less
),
523 "Takes two lists @var{alist} and @var{blist} such that\n"
524 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
525 "returns a new list in which the elements of @var{alist} and\n"
526 "@var{blist} have been stably interleaved so that\n"
527 "@code{(sorted? (merge alist blist less?) less?)}.\n"
528 "Note: this does _not_ accept vectors.")
529 #define FUNC_NAME s_scm_merge
531 long alen
, blen
; /* list lengths */
533 cmp_fun_t cmp
= scm_cmp_function (less
);
534 SCM_VALIDATE_NIM (3,less
);
536 if (SCM_NULLP (alist
))
538 else if (SCM_NULLP (blist
))
542 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1,alist
,alen
);
543 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2,blist
,blen
);
544 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
546 build
= scm_cons (SCM_CAR (blist
), SCM_EOL
);
547 blist
= SCM_CDR (blist
);
552 build
= scm_cons (SCM_CAR (alist
), SCM_EOL
);
553 alist
= SCM_CDR (alist
);
557 while ((alen
> 0) && (blen
> 0))
559 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
561 SCM_SETCDR (last
, scm_cons (SCM_CAR (blist
), SCM_EOL
));
562 blist
= SCM_CDR (blist
);
567 SCM_SETCDR (last
, scm_cons (SCM_CAR (alist
), SCM_EOL
));
568 alist
= SCM_CDR (alist
);
571 last
= SCM_CDR (last
);
573 if ((alen
> 0) && (blen
== 0))
574 SCM_SETCDR (last
, alist
);
575 else if ((alen
== 0) && (blen
> 0))
576 SCM_SETCDR (last
, blist
);
584 scm_merge_list_x (SCM alist
, SCM blist
,
585 long alen
, long blen
,
586 cmp_fun_t cmp
, SCM less
)
590 if (SCM_NULLP (alist
))
592 else if (SCM_NULLP (blist
))
596 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
599 blist
= SCM_CDR (blist
);
605 alist
= SCM_CDR (alist
);
609 while ((alen
> 0) && (blen
> 0))
611 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
613 SCM_SETCDR (last
, blist
);
614 blist
= SCM_CDR (blist
);
619 SCM_SETCDR (last
, alist
);
620 alist
= SCM_CDR (alist
);
623 last
= SCM_CDR (last
);
625 if ((alen
> 0) && (blen
== 0))
626 SCM_SETCDR (last
, alist
);
627 else if ((alen
== 0) && (blen
> 0))
628 SCM_SETCDR (last
, blist
);
631 } /* scm_merge_list_x */
633 SCM_DEFINE (scm_merge_x
, "merge!", 3, 0, 0,
634 (SCM alist
, SCM blist
, SCM less
),
635 "Takes two lists @var{alist} and @var{blist} such that\n"
636 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
637 "returns a new list in which the elements of @var{alist} and\n"
638 "@var{blist} have been stably interleaved so that\n"
639 " @code{(sorted? (merge alist blist less?) less?)}.\n"
640 "This is the destructive variant of @code{merge}\n"
641 "Note: this does _not_ accept vectors.")
642 #define FUNC_NAME s_scm_merge_x
644 long alen
, blen
; /* list lengths */
646 SCM_VALIDATE_NIM (3,less
);
647 if (SCM_NULLP (alist
))
649 else if (SCM_NULLP (blist
))
653 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1,alist
,alen
);
654 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2,blist
,blen
);
655 return scm_merge_list_x (alist
, blist
,
657 scm_cmp_function (less
),
663 /* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
664 The algorithm is stable. We also tried to use the algorithm used by
665 scsh's merge-sort but that algorithm showed to not be stable, even
666 though it claimed to be.
669 scm_merge_list_step (SCM
* seq
,
679 a
= scm_merge_list_step (seq
, cmp
, less
, mid
);
680 b
= scm_merge_list_step (seq
, cmp
, less
, n
- mid
);
681 return scm_merge_list_x (a
, b
, mid
, n
- mid
, cmp
, less
);
686 SCM rest
= SCM_CDR (*seq
);
687 SCM x
= SCM_CAR (*seq
);
688 SCM y
= SCM_CAR (SCM_CDR (*seq
));
689 *seq
= SCM_CDR (rest
);
690 SCM_SETCDR (rest
, SCM_EOL
);
691 if ((*cmp
) (less
, &y
, &x
))
694 SCM_SETCAR (rest
, x
);
702 SCM_SETCDR (p
, SCM_EOL
);
707 } /* scm_merge_list_step */
710 /* scm_sort_x manages lists and vectors, not stable sort */
711 SCM_DEFINE (scm_sort_x
, "sort!", 2, 0, 0,
712 (SCM items
, SCM less
),
713 "Sort the sequence @var{items}, which may be a list or a\n"
714 "vector. @var{less} is used for comparing the sequence\n"
715 "elements. The sorting is destructive, that means that the\n"
716 "input sequence is modified to produce the sorted result.\n"
717 "This is not a stable sort.")
718 #define FUNC_NAME s_scm_sort_x
720 long len
; /* list/vector length */
721 if (SCM_NULLP(items
))
724 SCM_VALIDATE_NIM (2,less
);
726 if (SCM_CONSP (items
))
728 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
729 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
731 else if (SCM_VECTORP (items
))
733 len
= SCM_VECTOR_LENGTH (items
);
734 scm_restricted_vector_sort_x (items
,
741 SCM_WRONG_TYPE_ARG (1, items
);
745 /* scm_sort manages lists and vectors, not stable sort */
747 SCM_DEFINE (scm_sort
, "sort", 2, 0, 0,
748 (SCM items
, SCM less
),
749 "Sort the sequence @var{items}, which may be a list or a\n"
750 "vector. @var{less} is used for comparing the sequence\n"
751 "elements. This is not a stable sort.")
752 #define FUNC_NAME s_scm_sort
754 if (SCM_NULLP(items
))
757 SCM_VALIDATE_NIM (2,less
);
758 if (SCM_CONSP (items
))
762 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
763 items
= scm_list_copy (items
);
764 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
767 /* support ordinary vectors even if arrays not available? */
768 else if (SCM_VECTORP (items
))
770 long len
= SCM_VECTOR_LENGTH (items
);
771 SCM sortvec
= scm_make_uve (len
, scm_array_prototype (items
));
773 scm_array_copy_x (items
, sortvec
);
774 scm_restricted_vector_sort_x (sortvec
,
782 SCM_WRONG_TYPE_ARG (1, items
);
787 scm_merge_vector_x (void *const vecbase
,
788 void *const tempbase
,
795 register SCM
*vp
= (SCM
*) vecbase
;
796 register SCM
*temp
= (SCM
*) tempbase
;
797 long it
; /* Index for temp vector */
798 long i1
= low
; /* Index for lower vector segment */
799 long i2
= mid
+ 1; /* Index for upper vector segment */
801 /* Copy while both segments contain more characters */
802 for (it
= low
; (i1
<= mid
) && (i2
<= high
); ++it
)
803 if ((*cmp
) (less
, &vp
[i2
], &vp
[i1
]))
808 /* Copy while first segment contains more characters */
810 temp
[it
++] = vp
[i1
++];
812 /* Copy while second segment contains more characters */
814 temp
[it
++] = vp
[i2
++];
816 /* Copy back from temp to vp */
817 for (it
= low
; it
<= high
; ++it
)
819 } /* scm_merge_vector_x */
822 scm_merge_vector_step (void *const vp
,
831 long mid
= (low
+ high
) / 2;
832 scm_merge_vector_step (vp
, temp
, cmp
, less
, low
, mid
);
833 scm_merge_vector_step (vp
, temp
, cmp
, less
, mid
+1, high
);
834 scm_merge_vector_x (vp
, temp
, cmp
, less
, low
, mid
, high
);
836 } /* scm_merge_vector_step */
839 /* stable-sort! manages lists and vectors */
841 SCM_DEFINE (scm_stable_sort_x
, "stable-sort!", 2, 0, 0,
842 (SCM items
, SCM less
),
843 "Sort the sequence @var{items}, which may be a list or a\n"
844 "vector. @var{less} is used for comparing the sequence elements.\n"
845 "The sorting is destructive, that means that the input sequence\n"
846 "is modified to produce the sorted result.\n"
847 "This is a stable sort.")
848 #define FUNC_NAME s_scm_stable_sort_x
850 long len
; /* list/vector length */
852 if (SCM_NULLP (items
))
855 SCM_VALIDATE_NIM (2,less
);
856 if (SCM_CONSP (items
))
858 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
859 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
861 else if (SCM_VECTORP (items
))
864 len
= SCM_VECTOR_LENGTH (items
);
865 temp
= malloc (len
* sizeof(SCM
));
866 vp
= SCM_VELTS (items
);
867 scm_merge_vector_step (vp
,
869 scm_cmp_function (less
),
877 SCM_WRONG_TYPE_ARG (1, items
);
881 /* stable_sort manages lists and vectors */
883 SCM_DEFINE (scm_stable_sort
, "stable-sort", 2, 0, 0,
884 (SCM items
, SCM less
),
885 "Sort the sequence @var{items}, which may be a list or a\n"
886 "vector. @var{less} is used for comparing the sequence elements.\n"
887 "This is a stable sort.")
888 #define FUNC_NAME s_scm_stable_sort
890 long len
; /* list/vector length */
891 if (SCM_NULLP (items
))
894 SCM_VALIDATE_NIM (2,less
);
895 if (SCM_CONSP (items
))
897 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
898 items
= scm_list_copy (items
);
899 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
902 /* support ordinary vectors even if arrays not available? */
903 else if (SCM_VECTORP (items
))
907 len
= SCM_VECTOR_LENGTH (items
);
908 retvec
= scm_make_uve (len
, scm_array_prototype (items
));
909 scm_array_copy_x (items
, retvec
);
910 temp
= malloc (len
* sizeof (SCM
));
911 vp
= SCM_VELTS (retvec
);
912 scm_merge_vector_step (vp
,
914 scm_cmp_function (less
),
923 SCM_WRONG_TYPE_ARG (1, items
);
928 SCM_DEFINE (scm_sort_list_x
, "sort-list!", 2, 0, 0,
929 (SCM items
, SCM less
),
930 "Sort the list @var{items}, using @var{less} for comparing the\n"
931 "list elements. The sorting is destructive, that means that the\n"
932 "input list is modified to produce the sorted result.\n"
933 "This is a stable sort.")
934 #define FUNC_NAME s_scm_sort_list_x
937 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
938 SCM_VALIDATE_NIM (2,less
);
939 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
944 SCM_DEFINE (scm_sort_list
, "sort-list", 2, 0, 0,
945 (SCM items
, SCM less
),
946 "Sort the list @var{items}, using @var{less} for comparing the\n"
947 "list elements. This is a stable sort.")
948 #define FUNC_NAME s_scm_sort_list
951 SCM_VALIDATE_LIST_COPYLEN (1,items
,len
);
952 SCM_VALIDATE_NIM (2,less
);
953 items
= scm_list_copy (items
);
954 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
961 #ifndef SCM_MAGIC_SNARFER
962 #include "libguile/sort.x"
965 scm_add_feature ("sort");