summaryrefslogtreecommitdiffstats
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/.depend8
-rw-r--r--stdlib/Makefile2
-rw-r--r--stdlib/array.ml137
-rw-r--r--stdlib/array.mli26
-rw-r--r--stdlib/list.ml27
-rw-r--r--stdlib/list.mli21
-rw-r--r--stdlib/sort.mli5
7 files changed, 208 insertions, 18 deletions
diff --git a/stdlib/.depend b/stdlib/.depend
index 88fb5e880..d1a4d2d80 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -4,8 +4,8 @@ parsing.cmi: lexing.cmi obj.cmi
printf.cmi: buffer.cmi
arg.cmo: array.cmi list.cmi printf.cmi string.cmi sys.cmi arg.cmi
arg.cmx: array.cmx list.cmx printf.cmx string.cmx sys.cmx arg.cmi
-array.cmo: list.cmi array.cmi
-array.cmx: list.cmx array.cmi
+array.cmo: array.cmi pervasives.cmi array.cmi
+array.cmx: array.cmx pervasives.cmx array.cmi
buffer.cmo: string.cmi sys.cmi buffer.cmi
buffer.cmx: string.cmx sys.cmx buffer.cmi
callback.cmo: obj.cmi callback.cmi
@@ -32,8 +32,8 @@ lazy.cmo: lazy.cmi
lazy.cmx: lazy.cmi
lexing.cmo: string.cmi lexing.cmi
lexing.cmx: string.cmx lexing.cmi
-list.cmo: list.cmi
-list.cmx: list.cmi
+list.cmo: array.cmi list.cmi
+list.cmx: array.cmx list.cmi
map.cmo: map.cmi
map.cmx: map.cmi
marshal.cmo: string.cmi marshal.cmi
diff --git a/stdlib/Makefile b/stdlib/Makefile
index bff51bfa4..83a41085b 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -23,7 +23,7 @@ CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
OPTCOMPFLAGS=
CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-OBJS=pervasives.cmo list.cmo char.cmo string.cmo array.cmo sys.cmo \
+OBJS=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
lexing.cmo parsing.cmo \
set.cmo map.cmo stack.cmo queue.cmo stream.cmo \
diff --git a/stdlib/array.ml b/stdlib/array.ml
index e3abd2687..af0195128 100644
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -59,17 +59,22 @@ let append a1 a2 =
end
let concat_aux init al =
- let size = List.fold_left (fun sz a -> sz + length a) 0 al in
- let res = create size init in
- let pos = ref 0 in
- List.iter
- (fun a ->
- for i = 0 to length a - 1 do
- unsafe_set res !pos (unsafe_get a i);
- incr pos
- done)
- al;
+ let rec size accu = function
+ | [] -> accu
+ | h::t -> size (accu + length h) t
+ in
+ let res = create (size 0 al) init in
+ let rec fill pos = function
+ | [] -> ()
+ | h::t ->
+ for i = 0 to length h - 1 do
+ unsafe_set res (pos + i) (unsafe_get h i);
+ done;
+ fill (pos + length h) t;
+ in
+ fill 0 al;
res
+;;
let concat al =
let rec find_init = function
@@ -138,10 +143,15 @@ let to_list a =
if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
tolist (length a - 1) []
+let rec list_length accu = function
+ | [] -> accu
+ | h::t -> list_length (succ accu) t
+;;
+
let of_list = function
[] -> [||]
- | hd::tl ->
- let a = create (List.length tl + 1) hd in
+ | hd::tl as l ->
+ let a = create (list_length 0 l) hd in
let rec fill i = function
[] -> a
| hd::tl -> unsafe_set a i hd; fill (i+1) tl in
@@ -160,3 +170,106 @@ let fold_right f a x =
r := f (unsafe_get a i) !r
done;
!r
+
+exception Bottom of int;;
+let sort cmp a =
+ let maxson l i =
+ let i31 = i+i+i+1 in
+ let x = ref i31 in
+ if i31+2 < l then begin
+ if cmp a.(i31) a.(i31+1) < 0 then x := i31+1;
+ if cmp a.(!x) a.(i31+2) < 0 then x := i31+2;
+ !x
+ end else
+ if i31+1 < l && cmp a.(i31) a.(i31+1) < 0
+ then i31+1
+ else if i31 < l then i31 else raise (Bottom i)
+ in
+ let rec trickledown l i e =
+ let j = maxson l i in
+ if cmp a.(j) e > 0 then begin
+ a.(i) <- a.(j);
+ trickledown l j e;
+ end else begin
+ a.(i) <- e;
+ end;
+ in
+ let rec trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in
+ let rec bubbledown l i =
+ let j = maxson l i in
+ a.(i) <- a.(j);
+ bubbledown l j;
+ in
+ let bubble l i = try bubbledown l i with Bottom i -> i in
+ let rec trickleup i e =
+ let father = (i - 1) / 3 in
+ assert (i <> father);
+ if cmp a.(father) e < 0 then begin
+ a.(i) <- a.(father);
+ if father > 0 then trickleup father e else a.(0) <- e;
+ end else begin
+ a.(i) <- e;
+ end;
+ in
+ let l = length a in
+ for i = (l + 1) / 3 - 1 downto 0 do trickle l i a.(i); done;
+ for i = l - 1 downto 2 do
+ let e = a.(i) in
+ a.(i) <- a.(0);
+ trickleup (bubble i 0) e;
+ done;
+ if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
+;;
+
+let cutoff = 5;;
+let stable_sort cmp a =
+ let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+ let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+ let rec loop i1 s1 i2 s2 d =
+ if cmp s1 s2 <= 0 then begin
+ dst.(d) <- s1;
+ let i1 = i1 + 1 in
+ if i1 < src1r then
+ loop i1 a.(i1) i2 s2 (d + 1)
+ else
+ blit src2 i2 dst (d + 1) (src2r - i2)
+ end else begin
+ dst.(d) <- s2;
+ let i2 = i2 + 1 in
+ if i2 < src2r then
+ loop i1 s1 i2 src2.(i2) (d + 1)
+ else
+ blit a i1 dst (d + 1) (src1r - i1)
+ end
+ in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs;
+ in
+ let isortto srcofs dst dstofs len =
+ for i = 0 to len - 1 do
+ let e = a.(srcofs + i) in
+ let j = ref (dstofs + i - 1) in
+ while (!j >= dstofs && cmp dst.(!j) e > 0) do
+ dst.(!j + 1) <- dst.(!j);
+ decr j;
+ done;
+ dst.(!j + 1) <- e;
+ done;
+ in
+ let rec sortto srcofs dst dstofs len =
+ if len <= cutoff then isortto srcofs dst dstofs len else begin
+ let l1 = len / 2 in
+ let l2 = len - l1 in
+ sortto (srcofs + l1) dst (dstofs + l1) l2;
+ sortto srcofs a (srcofs + l2) l1;
+ merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+ end;
+ in
+ let l = length a in
+ if l <= cutoff then isortto 0 a 0 l else begin
+ let l1 = l / 2 in
+ let l2 = l - l1 in
+ let t = make l2 a.(0) in
+ sortto l1 t 0 l2;
+ sortto 0 a l2 l1;
+ merge l2 l1 t 0 l2 a 0;
+ end;
+;;
diff --git a/stdlib/array.mli b/stdlib/array.mli
index f45cac336..18ae9db2f 100644
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -117,8 +117,32 @@ val fold_right: f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a
(* [Array.fold_right f a x] computes
[f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
where [n] is the length of the array [a]. *)
+
+(** Sorting *)
+val sort : cmp:('a -> 'a -> int) -> 'a array -> unit;;
+ (* Sort an array in increasing order according to a comparison
+ function. The comparison function must return 0 if it arguments
+ compare as equal, a positive integer if the first is greater,
+ and a negative integer if the first is smaller. For example,
+ the [compare] function is a suitable comparison function.
+ After calling [Array.sort], the array is sorted in place in
+ increasing order.
+ [Array.sort] is guaranteed to run in constant heap space
+ and logarithmic stack space.
+
+ The current implementation uses Heap Sort. It runs in constant
+ stack space.
+ *)
+
+val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit;;
+ (* Same as [Array.sort], but the sorting algorithm is stable and
+ not guaranteed to use a fixed amount of heap memory.
+ The current implementation is Merge Sort. It uses [n/2]
+ words of heap space, where [n] is the length of the array.
+ It is faster than the current implementation of [Array.sort].
+ *)
+
(*--*)
external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
-
diff --git a/stdlib/list.ml b/stdlib/list.ml
index be2e8a22c..021deb572 100644
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -191,3 +191,30 @@ let rec combine l1 l2 =
([], []) -> []
| (a1::l1, a2::l2) -> (a1, a2) :: combine l1 l2
| (_, _) -> invalid_arg "List.combine"
+
+(** sorting *)
+
+external obj_truncate : 'a array -> int -> unit = "obj_truncate"
+
+let array_to_list_in_place a =
+ let l = Array.length a in
+ let rec loop accu n p =
+ if p <= 0 then accu else begin
+ if p = n then begin
+ obj_truncate a p;
+ loop (a.(p-1) :: accu) (n-1000) (p-1)
+ end else begin
+ loop (a.(p-1) :: accu) n (p-1)
+ end
+ end
+ in
+ loop [] l l
+;;
+
+let stable_sort cmp l =
+ let a = Array.of_list l in
+ Array.stable_sort cmp a;
+ array_to_list_in_place a
+;;
+
+let sort = stable_sort;;
diff --git a/stdlib/list.mli b/stdlib/list.mli
index cb2345353..d76c0b7c3 100644
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -188,3 +188,24 @@ val combine : 'a list -> 'b list -> ('a * 'b) list
[[(a1,b1); ...; (an,bn)]].
Raise [Invalid_argument] if the two lists
have different lengths. Not tail-recursive. *)
+
+(** Sorting *)
+val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list;;
+ (* Sort a list in increasing order according to a comparison
+ function. The comparison function must return 0 if it arguments
+ compare as equal, a positive integer if the first is greater,
+ and a negative integer if the first is smaller. For example,
+ the [compare] function is a suitable comparison function.
+ The resulting list is sorted in increasing order.
+ [List.sort] is guaranteed to run in constant heap space
+ (in addition to the size of the result list) and logarithmic
+ stack space.
+
+ The current implementation uses Merge Sort and is the same as
+ [List.stable_sort].
+ *)
+val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list;;
+ (* Same as [List.sort], but the sorting algorithm is stable.
+ The current implementation is Merge Sort. It runs in constant
+ heap space.
+ *)
diff --git a/stdlib/sort.mli b/stdlib/sort.mli
index 413057090..684fb41d0 100644
--- a/stdlib/sort.mli
+++ b/stdlib/sort.mli
@@ -14,6 +14,11 @@
(* Module [Sort]: sorting and merging lists *)
+(* This module is obsolete and exists only for backward compatibility.
+ The sorting functions in [Array] and [List] should be used instead.
+ The new functions are faster and use less memory.
+*)
+
val list : order:('a -> 'a -> bool) -> 'a list -> 'a list
(* Sort a list in increasing order according to an ordering predicate.
The predicate should return [true] if its first argument is
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-22 23:00:45 +0000