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 */
81 #include "libguile/_scm.h"
83 #include "libguile/eval.h"
84 #include "libguile/unif.h"
85 #include "libguile/ramap.h"
86 #include "libguile/alist.h"
87 #include "libguile/feature.h"
88 #include "libguile/vectors.h"
90 #include "libguile/validate.h"
91 #include "libguile/sort.h"
93 /* The routine quicksort was extracted from the GNU C Library qsort.c
94 written by Douglas C. Schmidt (schmidt@ics.uci.edu)
95 and adapted to guile by adding an extra pointer less
96 to quicksort by Roland Orre <orre@nada.kth.se>.
98 The reason to do this instead of using the library function qsort
99 was to avoid dependency of the ANSI-C extensions for local functions
100 and also to avoid obscure pool based solutions.
102 This sorting routine is not much more efficient than the stable
103 version but doesn't consume extra memory.
106 /* Byte-wise swap two items of size SIZE. */
107 #define SWAP(a, b, size) \
110 register size_t __size = (size); \
111 register char *__a = (a), *__b = (b); \
117 } while (--__size > 0); \
120 /* Discontinue quicksort algorithm when partition gets below this size.
121 This particular magic number was chosen to work best on a Sun 4/260. */
124 /* Stack node declarations used to store unfulfilled partition obligations. */
132 /* The next 4 #defines implement a very fast in-line stack abstraction. */
133 #define STACK_SIZE (8 * sizeof(unsigned long int))
134 #define PUSH(low, high) ((void) ((top->lo = (low)), (top->hi = (high)), ++top))
135 #define POP(low, high) ((void) (--top, (low = top->lo), (high = top->hi)))
136 #define STACK_NOT_EMPTY (stack < top)
139 /* Order size using quicksort. This implementation incorporates
140 four optimizations discussed in Sedgewick:
142 1. Non-recursive, using an explicit stack of pointer that store the
143 next array partition to sort. To save time, this maximum amount
144 of space required to store an array of MAX_INT is allocated on the
145 stack. Assuming a 32-bit integer, this needs only 32 *
146 sizeof(stack_node) == 136 bits. Pretty cheap, actually.
148 2. Chose the pivot element using a median-of-three decision tree.
149 This reduces the probability of selecting a bad pivot value and
150 eliminates certain extraneous comparisons.
152 3. Only quicksorts TOTAL_ELEMS / MAX_THRESH partitions, leaving
153 insertion sort to order the MAX_THRESH items within each partition.
154 This is a big win, since insertion sort is faster for small, mostly
155 sorted array segments.
157 4. The larger of the two sub-partitions is always pushed onto the
158 stack first, with the algorithm then concentrating on the
159 smaller partition. This *guarantees* no more than log (n)
160 stack size is needed (actually O(1) in this case)! */
162 typedef int (*cmp_fun_t
) (SCM less
,
166 static const char s_buggy_less
[] = "buggy less predicate used when sorting";
169 quicksort (void *const pbase
,
175 register char *base_ptr
= (char *) pbase
;
177 /* Allocating SIZE bytes for a pivot buffer facilitates a better
178 algorithm below since we can do comparisons directly on the pivot. */
179 char *pivot_buffer
= (char *) alloca (size
);
180 const size_t max_thresh
= MAX_THRESH
* size
;
182 if (total_elems
== 0)
183 /* Avoid lossage with unsigned arithmetic below. */
186 if (total_elems
> MAX_THRESH
)
189 char *hi
= &lo
[size
* (total_elems
- 1)];
190 /* Largest size needed for 32-bit int!!! */
191 stack_node stack
[STACK_SIZE
];
192 stack_node
*top
= stack
+ 1;
194 while (STACK_NOT_EMPTY
)
199 char *pivot
= pivot_buffer
;
201 /* Select median value from among LO, MID, and HI. Rearrange
202 LO and HI so the three values are sorted. This lowers the
203 probability of picking a pathological pivot value and
204 skips a comparison for both the LEFT_PTR and RIGHT_PTR. */
206 char *mid
= lo
+ size
* ((hi
- lo
) / size
>> 1);
208 if ((*cmp
) (less
, (void *) mid
, (void *) lo
))
209 SWAP (mid
, lo
, size
);
210 if ((*cmp
) (less
, (void *) hi
, (void *) mid
))
211 SWAP (mid
, hi
, size
);
214 if ((*cmp
) (less
, (void *) mid
, (void *) lo
))
215 SWAP (mid
, lo
, size
);
217 memcpy (pivot
, mid
, size
);
218 pivot
= pivot_buffer
;
220 left_ptr
= lo
+ size
;
221 right_ptr
= hi
- size
;
223 /* Here's the famous ``collapse the walls'' section of quicksort.
224 Gotta like those tight inner loops! They are the main reason
225 that this algorithm runs much faster than others. */
228 while ((*cmp
) (less
, (void *) left_ptr
, (void *) pivot
))
231 /* The comparison predicate may be buggy */
233 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
236 while ((*cmp
) (less
, (void *) pivot
, (void *) right_ptr
))
239 /* The comparison predicate may be buggy */
241 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
244 if (left_ptr
< right_ptr
)
246 SWAP (left_ptr
, right_ptr
, size
);
250 else if (left_ptr
== right_ptr
)
257 while (left_ptr
<= right_ptr
);
259 /* Set up pointers for next iteration. First determine whether
260 left and right partitions are below the threshold size. If so,
261 ignore one or both. Otherwise, push the larger partition's
262 bounds on the stack and continue sorting the smaller one. */
264 if ((size_t) (right_ptr
- lo
) <= max_thresh
)
266 if ((size_t) (hi
- left_ptr
) <= max_thresh
)
267 /* Ignore both small partitions. */
270 /* Ignore small left partition. */
273 else if ((size_t) (hi
- left_ptr
) <= max_thresh
)
274 /* Ignore small right partition. */
276 else if ((right_ptr
- lo
) > (hi
- left_ptr
))
278 /* Push larger left partition indices. */
279 PUSH (lo
, right_ptr
);
284 /* Push larger right partition indices. */
291 /* Once the BASE_PTR array is partially sorted by quicksort the rest
292 is completely sorted using insertion sort, since this is efficient
293 for partitions below MAX_THRESH size. BASE_PTR points to the beginning
294 of the array to sort, and END_PTR points at the very last element in
295 the array (*not* one beyond it!). */
298 char *const end_ptr
= &base_ptr
[size
* (total_elems
- 1)];
299 char *tmp_ptr
= base_ptr
;
300 char *thresh
= min (end_ptr
, base_ptr
+ max_thresh
);
301 register char *run_ptr
;
303 /* Find smallest element in first threshold and place it at the
304 array's beginning. This is the smallest array element,
305 and the operation speeds up insertion sort's inner loop. */
307 for (run_ptr
= tmp_ptr
+ size
; run_ptr
<= thresh
; run_ptr
+= size
)
308 if ((*cmp
) (less
, (void *) run_ptr
, (void *) tmp_ptr
))
311 if (tmp_ptr
!= base_ptr
)
312 SWAP (tmp_ptr
, base_ptr
, size
);
314 /* Insertion sort, running from left-hand-side up to right-hand-side. */
316 run_ptr
= base_ptr
+ size
;
317 while ((run_ptr
+= size
) <= end_ptr
)
319 tmp_ptr
= run_ptr
- size
;
320 while ((*cmp
) (less
, (void *) run_ptr
, (void *) tmp_ptr
))
323 /* The comparison predicate may be buggy */
324 if (tmp_ptr
< base_ptr
)
325 scm_misc_error (NULL
, s_buggy_less
, SCM_EOL
);
329 if (tmp_ptr
!= run_ptr
)
333 trav
= run_ptr
+ size
;
334 while (--trav
>= run_ptr
)
339 for (hi
= lo
= trav
; (lo
-= size
) >= tmp_ptr
; hi
= lo
)
349 /* comparison routines */
352 subr2less (SCM less
, const void *a
, const void *b
)
354 return SCM_NFALSEP (SCM_SUBRF (less
) (*(SCM
*) a
, *(SCM
*) b
));
358 subr2oless (SCM less
, const void *a
, const void *b
)
360 return SCM_NFALSEP (SCM_SUBRF (less
) (*(SCM
*) a
,
366 lsubrless (SCM less
, const void *a
, const void *b
)
368 return SCM_NFALSEP (SCM_SUBRF (less
)
369 (scm_cons (*(SCM
*) a
,
370 scm_cons (*(SCM
*) b
, SCM_EOL
))));
374 closureless (SCM code
, const void *a
, const void *b
)
376 SCM env
= SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code
)),
377 scm_cons (*(SCM
*) a
,
378 scm_cons (*(SCM
*) b
, SCM_EOL
)),
380 /* Evaluate the closure body */
381 return SCM_NFALSEP (scm_eval_body (SCM_CDR (SCM_CODE (code
)), env
));
385 applyless (SCM less
, const void *a
, const void *b
)
387 return SCM_NFALSEP (scm_apply (less
,
388 scm_cons (*(SCM
*) a
,
389 scm_cons (*(SCM
*) b
, SCM_EOL
)),
394 scm_cmp_function (SCM p
)
396 switch (SCM_TYP7 (p
))
402 case scm_tc7_subr_2o
:
406 case scm_tcs_closures
:
411 } /* scm_cmp_function */
414 /* Question: Is there any need to make this a more general array sort?
415 It is probably enough to manage the vector type. */
416 /* endpos equal as for substring, i.e. endpos is not included. */
417 /* More natural with length? */
419 SCM_DEFINE (scm_restricted_vector_sort_x
, "restricted-vector-sort!", 4, 0, 0,
420 (SCM vec
, SCM less
, SCM startpos
, SCM endpos
),
421 "Sort the vector @var{vec}, using @var{less} for comparing\n"
422 "the vector elements. @var{startpos} and @var{endpos} delimit\n"
423 "the range of the vector which gets sorted. The return value\n"
425 #define FUNC_NAME s_scm_restricted_vector_sort_x
427 size_t vlen
, spos
, len
, size
= sizeof (SCM
);
430 SCM_VALIDATE_VECTOR (1,vec
);
431 SCM_VALIDATE_NIM (2,less
);
433 vp
= SCM_VELTS (vec
); /* vector pointer */
434 vlen
= SCM_VECTOR_LENGTH (vec
);
436 SCM_VALIDATE_INUM_COPY (3,startpos
,spos
);
437 SCM_ASSERT_RANGE (3,startpos
,(spos
>= 0) && (spos
<= vlen
));
438 SCM_VALIDATE_INUM_RANGE (4,endpos
,0,vlen
+1);
439 len
= SCM_INUM (endpos
) - spos
;
441 quicksort (&vp
[spos
], len
, size
, scm_cmp_function (less
), less
);
442 return SCM_UNSPECIFIED
;
447 /* (sorted? sequence less?)
448 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
449 * such that for all 1 <= i <= m,
450 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
451 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
452 (SCM items
, SCM less
),
453 "Return @code{#t} iff @var{items} is a list or a vector such that\n"
454 "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
455 "applied to all elements i - 1 and i")
456 #define FUNC_NAME s_scm_sorted_p
458 long len
, j
; /* list/vector length, temp j */
459 SCM item
, rest
; /* rest of items loop variable */
461 cmp_fun_t cmp
= scm_cmp_function (less
);
463 if (SCM_NULLP (items
))
466 SCM_VALIDATE_NIM (2,less
);
468 if (SCM_CONSP (items
))
470 len
= scm_ilength (items
); /* also checks that it's a pure list */
471 SCM_ASSERT_RANGE (1,items
,len
>= 0);
475 item
= SCM_CAR (items
);
476 rest
= SCM_CDR (items
);
480 if ((*cmp
) (less
, SCM_CARLOC(rest
), &item
))
484 item
= SCM_CAR (rest
);
485 rest
= SCM_CDR (rest
);
493 SCM_VALIDATE_VECTOR (1, items
);
495 vp
= SCM_VELTS (items
); /* vector pointer */
496 len
= SCM_VECTOR_LENGTH (items
);
500 if ((*cmp
) (less
, &vp
[1], vp
))
516 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
517 and returns a new list in which the elements of a and b have been stably
518 interleaved so that (sorted? (merge a b less?) less?).
519 Note: this does _not_ accept vectors. */
520 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
521 (SCM alist
, SCM blist
, SCM less
),
522 "Takes two lists @var{alist} and @var{blist} such that\n"
523 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
524 "returns 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_NULLP (alist
))
537 else if (SCM_NULLP (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_NULLP (alist
))
591 else if (SCM_NULLP (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_NULLP (alist
))
648 else if (SCM_NULLP (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_NULLP(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 RETURN_SCM_WTA (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 SCM sortvec
; /* the vector we actually sort */
754 long len
; /* list/vector length */
755 if (SCM_NULLP(items
))
758 SCM_VALIDATE_NIM (2,less
);
759 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 len
= SCM_VECTOR_LENGTH (items
);
770 sortvec
= scm_make_uve (len
, scm_array_prototype (items
));
771 scm_array_copy_x (items
, sortvec
);
772 scm_restricted_vector_sort_x (sortvec
,
780 RETURN_SCM_WTA (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_NULLP (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 RETURN_SCM_WTA (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_NULLP (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 RETURN_SCM_WTA (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");