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. */
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 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_CLOSURE_FORMALS (code
),
378 scm_cons (*(SCM
*) a
,
379 scm_cons (*(SCM
*) b
, SCM_EOL
)),
381 /* Evaluate the closure body */
382 return !SCM_FALSEP (scm_eval_body (SCM_CLOSURE_BODY (code
), env
));
386 applyless (SCM less
, const void *a
, const void *b
)
388 return SCM_NFALSEP (scm_call_2 (less
, *(SCM
*) a
, *(SCM
*) b
));
392 scm_cmp_function (SCM p
)
394 switch (SCM_TYP7 (p
))
400 case scm_tc7_subr_2o
:
404 case scm_tcs_closures
:
409 } /* scm_cmp_function */
412 /* Question: Is there any need to make this a more general array sort?
413 It is probably enough to manage the vector type. */
414 /* endpos equal as for substring, i.e. endpos is not included. */
415 /* More natural with length? */
417 SCM_DEFINE (scm_restricted_vector_sort_x
, "restricted-vector-sort!", 4, 0, 0,
418 (SCM vec
, SCM less
, SCM startpos
, SCM endpos
),
419 "Sort the vector @var{vec}, using @var{less} for comparing\n"
420 "the vector elements. @var{startpos} and @var{endpos} delimit\n"
421 "the range of the vector which gets sorted. The return value\n"
423 #define FUNC_NAME s_scm_restricted_vector_sort_x
425 size_t vlen
, spos
, len
, size
= sizeof (SCM
);
428 SCM_VALIDATE_VECTOR (1,vec
);
429 SCM_VALIDATE_NIM (2,less
);
431 vp
= SCM_VELTS (vec
); /* vector pointer */
432 vlen
= SCM_VECTOR_LENGTH (vec
);
434 SCM_VALIDATE_INUM_MIN_COPY (3, startpos
, 0, spos
);
435 SCM_ASSERT_RANGE (3,startpos
, spos
<= vlen
);
436 SCM_VALIDATE_INUM_RANGE (4,endpos
,0,vlen
+1);
437 len
= SCM_INUM (endpos
) - spos
;
439 quicksort (&vp
[spos
], len
, size
, scm_cmp_function (less
), less
);
440 return SCM_UNSPECIFIED
;
445 /* (sorted? sequence less?)
446 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
447 * such that for all 1 <= i <= m,
448 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
449 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
450 (SCM items
, SCM less
),
451 "Return @code{#t} iff @var{items} is a list or a vector such that\n"
452 "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
453 "applied to all elements i - 1 and i")
454 #define FUNC_NAME s_scm_sorted_p
456 long len
, j
; /* list/vector length, temp j */
457 SCM item
, rest
; /* rest of items loop variable */
459 cmp_fun_t cmp
= scm_cmp_function (less
);
461 if (SCM_NULL_OR_NIL_P (items
))
464 SCM_VALIDATE_NIM (2,less
);
466 if (SCM_CONSP (items
))
468 len
= scm_ilength (items
); /* also checks that it's a pure list */
469 SCM_ASSERT_RANGE (1,items
,len
>= 0);
473 item
= SCM_CAR (items
);
474 rest
= SCM_CDR (items
);
478 if ((*cmp
) (less
, SCM_CARLOC(rest
), &item
))
482 item
= SCM_CAR (rest
);
483 rest
= SCM_CDR (rest
);
491 SCM_VALIDATE_VECTOR (1, items
);
493 vp
= SCM_VELTS (items
); /* vector pointer */
494 len
= SCM_VECTOR_LENGTH (items
);
498 if ((*cmp
) (less
, &vp
[1], vp
))
514 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
515 and returns a new list in which the elements of a and b have been stably
516 interleaved so that (sorted? (merge a b less?) less?).
517 Note: this does _not_ accept vectors. */
518 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
519 (SCM alist
, SCM blist
, SCM less
),
520 "Merge two already sorted lists into one.\n"
521 "Given two lists @var{alist} and @var{blist}, such that\n"
522 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
523 "return 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_NULL_OR_NIL_P (alist
))
536 else if (SCM_NULL_OR_NIL_P (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_NULL_OR_NIL_P (alist
))
590 else if (SCM_NULL_OR_NIL_P (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_NULL_OR_NIL_P (alist
))
647 else if (SCM_NULL_OR_NIL_P (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_NULL_OR_NIL_P (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_NULL_OR_NIL_P (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_NULL_OR_NIL_P (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_NULL_OR_NIL_P (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");