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_WRITABLE_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
);
441 return SCM_UNSPECIFIED
;
446 /* (sorted? sequence less?)
447 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
448 * such that for all 1 <= i <= m,
449 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
450 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
451 (SCM items
, SCM less
),
452 "Return @code{#t} iff @var{items} is a list or a vector such that\n"
453 "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
454 "applied to all elements i - 1 and i")
455 #define FUNC_NAME s_scm_sorted_p
457 long len
, j
; /* list/vector length, temp j */
458 SCM item
, rest
; /* rest of items loop variable */
460 cmp_fun_t cmp
= scm_cmp_function (less
);
462 if (SCM_NULL_OR_NIL_P (items
))
465 SCM_VALIDATE_NIM (2, less
);
467 if (SCM_CONSP (items
))
469 len
= scm_ilength (items
); /* also checks that it's a pure list */
470 SCM_ASSERT_RANGE (1, items
, len
>= 0);
474 item
= SCM_CAR (items
);
475 rest
= SCM_CDR (items
);
479 if ((*cmp
) (less
, SCM_CARLOC(rest
), &item
))
483 item
= SCM_CAR (rest
);
484 rest
= SCM_CDR (rest
);
492 SCM_VALIDATE_VECTOR (1, items
);
494 vp
= SCM_VELTS (items
); /* vector pointer */
495 len
= SCM_VECTOR_LENGTH (items
);
499 if ((*cmp
) (less
, &vp
[1], vp
))
515 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
516 and returns a new list in which the elements of a and b have been stably
517 interleaved so that (sorted? (merge a b less?) less?).
518 Note: this does _not_ accept vectors. */
519 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
520 (SCM alist
, SCM blist
, SCM less
),
521 "Merge two already sorted lists into one.\n"
522 "Given two lists @var{alist} and @var{blist}, such that\n"
523 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
524 "return a new list in which the elements of @var{alist} and\n"
525 "@var{blist} have been stably interleaved so that\n"
526 "@code{(sorted? (merge alist blist less?) less?)}.\n"
527 "Note: this does _not_ accept vectors.")
528 #define FUNC_NAME s_scm_merge
530 long alen
, blen
; /* list lengths */
532 cmp_fun_t cmp
= scm_cmp_function (less
);
533 SCM_VALIDATE_NIM (3, less
);
535 if (SCM_NULL_OR_NIL_P (alist
))
537 else if (SCM_NULL_OR_NIL_P (blist
))
541 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
542 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
543 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
545 build
= scm_cons (SCM_CAR (blist
), SCM_EOL
);
546 blist
= SCM_CDR (blist
);
551 build
= scm_cons (SCM_CAR (alist
), SCM_EOL
);
552 alist
= SCM_CDR (alist
);
556 while ((alen
> 0) && (blen
> 0))
558 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
560 SCM_SETCDR (last
, scm_cons (SCM_CAR (blist
), SCM_EOL
));
561 blist
= SCM_CDR (blist
);
566 SCM_SETCDR (last
, scm_cons (SCM_CAR (alist
), SCM_EOL
));
567 alist
= SCM_CDR (alist
);
570 last
= SCM_CDR (last
);
572 if ((alen
> 0) && (blen
== 0))
573 SCM_SETCDR (last
, alist
);
574 else if ((alen
== 0) && (blen
> 0))
575 SCM_SETCDR (last
, blist
);
583 scm_merge_list_x (SCM alist
, SCM blist
,
584 long alen
, long blen
,
585 cmp_fun_t cmp
, SCM less
)
589 if (SCM_NULL_OR_NIL_P (alist
))
591 else if (SCM_NULL_OR_NIL_P (blist
))
595 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
598 blist
= SCM_CDR (blist
);
604 alist
= SCM_CDR (alist
);
608 while ((alen
> 0) && (blen
> 0))
610 if ((*cmp
) (less
, SCM_CARLOC (blist
), SCM_CARLOC (alist
)))
612 SCM_SETCDR (last
, blist
);
613 blist
= SCM_CDR (blist
);
618 SCM_SETCDR (last
, alist
);
619 alist
= SCM_CDR (alist
);
622 last
= SCM_CDR (last
);
624 if ((alen
> 0) && (blen
== 0))
625 SCM_SETCDR (last
, alist
);
626 else if ((alen
== 0) && (blen
> 0))
627 SCM_SETCDR (last
, blist
);
630 } /* scm_merge_list_x */
632 SCM_DEFINE (scm_merge_x
, "merge!", 3, 0, 0,
633 (SCM alist
, SCM blist
, SCM less
),
634 "Takes two lists @var{alist} and @var{blist} such that\n"
635 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
636 "returns a new list in which the elements of @var{alist} and\n"
637 "@var{blist} have been stably interleaved so that\n"
638 " @code{(sorted? (merge alist blist less?) less?)}.\n"
639 "This is the destructive variant of @code{merge}\n"
640 "Note: this does _not_ accept vectors.")
641 #define FUNC_NAME s_scm_merge_x
643 long alen
, blen
; /* list lengths */
645 SCM_VALIDATE_NIM (3, less
);
646 if (SCM_NULL_OR_NIL_P (alist
))
648 else if (SCM_NULL_OR_NIL_P (blist
))
652 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
653 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
654 return scm_merge_list_x (alist
, blist
,
656 scm_cmp_function (less
),
662 /* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
663 The algorithm is stable. We also tried to use the algorithm used by
664 scsh's merge-sort but that algorithm showed to not be stable, even
665 though it claimed to be.
668 scm_merge_list_step (SCM
* seq
,
678 a
= scm_merge_list_step (seq
, cmp
, less
, mid
);
679 b
= scm_merge_list_step (seq
, cmp
, less
, n
- mid
);
680 return scm_merge_list_x (a
, b
, mid
, n
- mid
, cmp
, less
);
685 SCM rest
= SCM_CDR (*seq
);
686 SCM x
= SCM_CAR (*seq
);
687 SCM y
= SCM_CAR (SCM_CDR (*seq
));
688 *seq
= SCM_CDR (rest
);
689 SCM_SETCDR (rest
, SCM_EOL
);
690 if ((*cmp
) (less
, &y
, &x
))
693 SCM_SETCAR (rest
, x
);
701 SCM_SETCDR (p
, SCM_EOL
);
706 } /* scm_merge_list_step */
709 /* scm_sort_x manages lists and vectors, not stable sort */
710 SCM_DEFINE (scm_sort_x
, "sort!", 2, 0, 0,
711 (SCM items
, SCM less
),
712 "Sort the sequence @var{items}, which may be a list or a\n"
713 "vector. @var{less} is used for comparing the sequence\n"
714 "elements. The sorting is destructive, that means that the\n"
715 "input sequence is modified to produce the sorted result.\n"
716 "This is not a stable sort.")
717 #define FUNC_NAME s_scm_sort_x
719 long len
; /* list/vector length */
720 if (SCM_NULL_OR_NIL_P (items
))
723 SCM_VALIDATE_NIM (2, less
);
725 if (SCM_CONSP (items
))
727 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
728 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
730 else if (SCM_VECTORP (items
))
732 len
= SCM_VECTOR_LENGTH (items
);
733 scm_restricted_vector_sort_x (items
,
740 SCM_WRONG_TYPE_ARG (1, items
);
744 /* scm_sort manages lists and vectors, not stable sort */
746 SCM_DEFINE (scm_sort
, "sort", 2, 0, 0,
747 (SCM items
, SCM less
),
748 "Sort the sequence @var{items}, which may be a list or a\n"
749 "vector. @var{less} is used for comparing the sequence\n"
750 "elements. This is not a stable sort.")
751 #define FUNC_NAME s_scm_sort
753 if (SCM_NULL_OR_NIL_P (items
))
756 SCM_VALIDATE_NIM (2, less
);
757 if (SCM_CONSP (items
))
761 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
762 items
= scm_list_copy (items
);
763 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
766 /* support ordinary vectors even if arrays not available? */
767 else if (SCM_VECTORP (items
))
769 long len
= SCM_VECTOR_LENGTH (items
);
770 SCM sortvec
= scm_make_uve (len
, scm_array_prototype (items
));
772 scm_array_copy_x (items
, sortvec
);
773 scm_restricted_vector_sort_x (sortvec
,
781 SCM_WRONG_TYPE_ARG (1, items
);
786 scm_merge_vector_x (SCM vec
,
794 long it
; /* Index for temp vector */
795 long i1
= low
; /* Index for lower vector segment */
796 long i2
= mid
+ 1; /* Index for upper vector segment */
798 /* Copy while both segments contain more characters */
799 for (it
= low
; (i1
<= mid
) && (i2
<= high
); ++it
)
802 Every call of LESS might invoke GC. For full correctness, we
803 should reset the generation of vecbase and tempbase between
807 register SCM
*vp
= SCM_WRITABLE_VELTS(vec
);
809 if ((*cmp
) (less
, &vp
[i2
], &vp
[i1
]))
816 register SCM
*vp
= SCM_WRITABLE_VELTS(vec
);
818 /* Copy while first segment contains more characters */
820 temp
[it
++] = vp
[i1
++];
822 /* Copy while second segment contains more characters */
824 temp
[it
++] = vp
[i2
++];
826 /* Copy back from temp to vp */
827 for (it
= low
; it
<= high
; ++it
)
830 } /* scm_merge_vector_x */
833 scm_merge_vector_step (SCM vp
,
842 long mid
= (low
+ high
) / 2;
843 scm_merge_vector_step (vp
, temp
, cmp
, less
, low
, mid
);
844 scm_merge_vector_step (vp
, temp
, cmp
, less
, mid
+1, high
);
845 scm_merge_vector_x (vp
, temp
, cmp
, less
, low
, mid
, high
);
847 } /* scm_merge_vector_step */
850 /* stable-sort! manages lists and vectors */
852 SCM_DEFINE (scm_stable_sort_x
, "stable-sort!", 2, 0, 0,
853 (SCM items
, SCM less
),
854 "Sort the sequence @var{items}, which may be a list or a\n"
855 "vector. @var{less} is used for comparing the sequence elements.\n"
856 "The sorting is destructive, that means that the input sequence\n"
857 "is modified to produce the sorted result.\n"
858 "This is a stable sort.")
859 #define FUNC_NAME s_scm_stable_sort_x
861 long len
; /* list/vector length */
863 if (SCM_NULL_OR_NIL_P (items
))
866 SCM_VALIDATE_NIM (2, less
);
867 if (SCM_CONSP (items
))
869 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
870 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
872 else if (SCM_VECTORP (items
))
875 len
= SCM_VECTOR_LENGTH (items
);
878 the following array does not contain any new references to
879 SCM objects, so we can get away with allocing it on the heap.
881 temp
= malloc (len
* sizeof(SCM
));
883 scm_merge_vector_step (items
,
885 scm_cmp_function (less
),
893 SCM_WRONG_TYPE_ARG (1, items
);
897 /* stable_sort manages lists and vectors */
898 SCM_DEFINE (scm_stable_sort
, "stable-sort", 2, 0, 0,
899 (SCM items
, SCM less
),
900 "Sort the sequence @var{items}, which may be a list or a\n"
901 "vector. @var{less} is used for comparing the sequence elements.\n"
902 "This is a stable sort.")
903 #define FUNC_NAME s_scm_stable_sort
906 if (SCM_NULL_OR_NIL_P (items
))
909 SCM_VALIDATE_NIM (2, less
);
910 if (SCM_CONSP (items
))
912 long len
; /* list/vector length */
913 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
914 items
= scm_list_copy (items
);
915 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
918 /* support ordinary vectors even if arrays not available? */
919 else if (SCM_VECTORP (items
))
921 long len
= SCM_VECTOR_LENGTH (items
);
922 SCM
*temp
= malloc (len
* sizeof (SCM
));
923 SCM retvec
= scm_make_uve (len
, scm_array_prototype (items
));
924 scm_array_copy_x (items
, retvec
);
926 scm_merge_vector_step (retvec
,
928 scm_cmp_function (less
),
937 SCM_WRONG_TYPE_ARG (1, items
);
942 SCM_DEFINE (scm_sort_list_x
, "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. The sorting is destructive, that means that the\n"
946 "input list is modified to produce the sorted result.\n"
947 "This is a stable sort.")
948 #define FUNC_NAME s_scm_sort_list_x
951 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
952 SCM_VALIDATE_NIM (2, less
);
953 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
958 SCM_DEFINE (scm_sort_list
, "sort-list", 2, 0, 0,
959 (SCM items
, SCM less
),
960 "Sort the list @var{items}, using @var{less} for comparing the\n"
961 "list elements. This is a stable sort.")
962 #define FUNC_NAME s_scm_sort_list
965 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
966 SCM_VALIDATE_NIM (2, less
);
967 items
= scm_list_copy (items
);
968 return scm_merge_list_step (&items
, scm_cmp_function (less
), less
, len
);
975 #include "libguile/sort.x"
977 scm_add_feature ("sort");