summaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/Makefile74
-rw-r--r--stdlib/Makefile.nt70
-rw-r--r--stdlib/arg.ml53
-rw-r--r--stdlib/arg.mli8
-rw-r--r--stdlib/buffer.ml26
-rw-r--r--stdlib/buffer.mli12
-rw-r--r--stdlib/camlinternalOO.ml413
-rw-r--r--stdlib/camlinternalOO.mli42
-rw-r--r--stdlib/filename.ml125
-rw-r--r--stdlib/filename.mli5
-rw-r--r--stdlib/format.mli7
-rw-r--r--stdlib/gc.ml1
-rw-r--r--stdlib/gc.mli23
-rw-r--r--stdlib/hashtbl.ml6
-rw-r--r--stdlib/hashtbl.mli8
-rw-r--r--stdlib/map.ml41
-rw-r--r--stdlib/map.mli13
-rw-r--r--stdlib/moreLabels.mli8
-rw-r--r--stdlib/oo.ml2
-rw-r--r--stdlib/oo.mli4
-rw-r--r--stdlib/parsing.mli2
-rw-r--r--stdlib/pervasives.mli12
-rw-r--r--stdlib/scanf.ml109
-rw-r--r--stdlib/scanf.mli3
-rw-r--r--stdlib/set.ml32
-rw-r--r--stdlib/set.mli9
-rw-r--r--stdlib/stdLabels.mli2
-rw-r--r--stdlib/sys.ml2
-rw-r--r--stdlib/sys.mli12
29 files changed, 606 insertions, 518 deletions
diff --git a/stdlib/Makefile b/stdlib/Makefile
index 38a4c85e76..570849ff0a 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -18,14 +18,17 @@ include ../config/Makefile
RUNTIME=../boot/ocamlrun
COMPILER=../ocamlc
CAMLC=$(RUNTIME) $(COMPILER)
-COMPFLAGS=-warn-error A -nostdlib
+COMPFLAGS=-g -warn-error A -nostdlib
OPTCOMPILER=../ocamlopt
CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
OPTCOMPFLAGS=-warn-error A -nostdlib
CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-BASIC=builtintypes.cmo \
- pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
+NOBUILTINFLAG=-nobuiltintypes
+
+OBJS=builtintypes.cmo \
+ pervasives.cmo $(OTHERS)
+OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
int32.cmo int64.cmo nativeint.cmo \
lexing.cmo parsing.cmo \
@@ -35,11 +38,17 @@ BASIC=builtintypes.cmo \
digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \
genlex.cmo weak.cmo \
lazy.cmo filename.cmo complex.cmo \
- rtype.cmo
-LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
-
-OBJS=$(BASIC) labelled.cmo stdLabels.cmo
-ALLOBJS=$(BASIC) $(LABELLED:.ml=.cmo) stdLabels.cmo
+ rtype.cmo \
+ arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo
+
+# make MODE=migration when you want to port gcaml to the latest ocaml-cvs
+ifeq ($(MODE),migration)
+ifeq ($(CAMLC),../boot/ocamlrun ../boot/ocamlc)
+# migration + coldstart
+NOBUILTINFLAG:=
+OBJS:=pervasives.cmo $(OTHERS)
+endif
+endif
all: stdlib.cma std_exit.cmo camlheader camlheader_ur
@@ -48,6 +57,7 @@ allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING)
allopt-noprof:
allopt-prof: stdlib.p.cmxa std_exit.p.cmx
+ rm -f std_exit.p.cmi
install:
cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \
@@ -71,13 +81,13 @@ installopt-prof:
cd $(LIBDIR); $(RANLIB) stdlib.p.a
stdlib.cma: $(OBJS)
- $(CAMLC) -a -o stdlib.cma $(ALLOBJS)
+ $(CAMLC) -a -o stdlib.cma $(OBJS)
stdlib.cmxa: $(OBJS:.cmo=.cmx)
- $(CAMLOPT) -a -o stdlib.cmxa $(ALLOBJS:.cmo=.cmx)
+ $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx)
stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx)
- $(CAMLOPT) -a -o stdlib.p.cmxa $(ALLOBJS:.cmo=.p.cmx)
+ $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx)
camlheader camlheader_ur: header.c ../config/Makefile
if $(SHARPBANGSCRIPTS); then \
@@ -118,20 +128,20 @@ pervasives.p.cmx: pervasives.ml
then mv pervasives.n.o pervasives.o; else :; fi
builtintypes.cmi: builtintypes.mli
- $(CAMLC) $(COMPFLAGS) -nobuiltintypes -c builtintypes.mli
+ $(CAMLC) $(COMPFLAGS) $(NOBUILTINFLAG) -c builtintypes.mli
builtintypes.cmo: builtintypes.ml
- $(CAMLC) $(COMPFLAGS) -nobuiltintypes -c builtintypes.ml
+ $(CAMLC) $(COMPFLAGS) $(NOBUILTINFLAG) -c builtintypes.ml
builtintypes.cmx: builtintypes.ml
- $(CAMLOPT) $(OPTCOMPFLAGS) -nobuiltintypes -c builtintypes.ml
+ $(CAMLOPT) $(OPTCOMPFLAGS) $(NOBUILTINFLAG) -c builtintypes.ml
builtintypes.p.cmx: builtintypes.ml
@if test -f builtintypes.cmx; \
then mv builtintypes.cmx builtintypes.n.cmx; else :; fi
@if test -f builtintypes.o; \
then mv builtintypes.o builtintypes.n.o; else :; fi
- $(CAMLOPT) $(OPTCOMPFLAGS) -p -nobuiltintypes -c builtintypes.ml
+ $(CAMLOPT) $(OPTCOMPFLAGS) -p $(NOBUILTINFLAG) -c builtintypes.ml
mv builtintypes.cmx builtintypes.p.cmx
mv builtintypes.o builtintypes.p.o
@if test -f builtintypes.n.cmx; \
@@ -184,28 +194,30 @@ labelled.p.cmx:
.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
.mli.cmi:
- $(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+ $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
.ml.cmo:
- $(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+ $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
.ml.cmx:
- $(CAMLOPT) $(OPTCOMPFLAGS) $(EXTRAFLAGS) -c $<
+ $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $<
.ml.p.cmx:
- @if test -f $*.cmx; then mv $*.cmx $*.n.cmx; else :; fi
- @if test -f $*.o; then mv $*.o $*.n.o; else :; fi
- $(CAMLOPT) $(OPTCOMPFLAGS) $(EXTRAFLAGS) -p -c $<
- mv $*.cmx $*.p.cmx
- mv $*.o $*.p.o
- @if test -f $*.n.cmx; then mv $*.n.cmx $*.cmx; else :; fi
- @if test -f $*.n.o; then mv $*.n.o $*.o; else :; fi
-
-$(ALLOBJS) labelled.cmo std_exit.cmo: pervasives.cmi $(COMPILER)
-$(ALLOBJS:.cmo=.cmx) labelled.cmx std_exit.cmx: pervasives.cmi $(OPTCOMPILER)
-$(ALLOBJS:.cmo=.p.cmx) labelled.p.cmx std_exit.p.cmx: pervasives.cmi $(OPTCOMPILER)
-$(ALLOBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
-labelled.cmo labelled.cmx labelled.p.cmx: $(LABELLED) $(LABELLED:.ml=.mli)
+ $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $<
+
+# Dependencies on the compiler
+$(OBJS) std_exit.cmo: $(COMPILER)
+$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
+$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER)
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER)
+
+# Dependencies on Pervasives (not tracked by ocamldep)
+$(OBJS) std_exit.cmo: pervasives.cmi
+$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi
+$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi
+$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx
+$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx
clean::
rm -f *.cm* *.o *.a
diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt
index 140ae4b2dc..5df7c7ea4e 100644
--- a/stdlib/Makefile.nt
+++ b/stdlib/Makefile.nt
@@ -18,24 +18,24 @@ include ../config/Makefile
RUNTIME=../boot/ocamlrun
COMPILER=../ocamlc
CAMLC=$(RUNTIME) $(COMPILER)
+COMPFLAGS=-warn-error A -nostdlib
OPTCOMPILER=../ocamlopt
CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
+OPTCOMPFLAGS=-warn-error A -nostdlib
CAMLDEP=../boot/ocamlrun ../tools/ocamldep
-BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
+OBJS=pervasives.cmo $(OTHERS)
+OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
int32.cmo int64.cmo nativeint.cmo \
lexing.cmo parsing.cmo \
set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \
printf.cmo format.cmo scanf.cmo \
arg.cmo printexc.cmo gc.cmo \
- digest.cmo random.cmo camlinternalOO.cmo oo.cmo \
- genlex.cmo callback.cmo weak.cmo \
- lazy.cmo filename.cmo complex.cmo
-LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
-
-OBJS=$(BASIC) labelled.cmo stdLabels.cmo
-ALLOBJS=$(BASIC) $(LABELLED:.ml=.cmo) stdLabels.cmo
+ digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \
+ genlex.cmo weak.cmo \
+ lazy.cmo filename.cmo complex.cmo \
+ arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo
all: stdlib.cma std_exit.cmo camlheader camlheader_ur
@@ -48,10 +48,10 @@ installopt:
cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR)
stdlib.cma: $(OBJS)
- $(CAMLC) -a -o stdlib.cma $(ALLOBJS)
+ $(CAMLC) -a -o stdlib.cma $(OBJS)
stdlib.cmxa: $(OBJS:.cmo=.cmx)
- $(CAMLOPT) -a -o stdlib.cmxa $(ALLOBJS:.cmo=.cmx)
+ $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx)
camlheader camlheader_ur: headernt.c ../config/Makefile
$(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o camlheader.exe headernt.c
@@ -61,46 +61,30 @@ camlheader camlheader_ur: headernt.c ../config/Makefile
clean::
rm -f camlheader camlheader_ur
-pervasives.cmi: pervasives.mli
- $(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.mli
-
-pervasives.cmo: pervasives.ml
- $(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.ml
-
-pervasives.cmx: pervasives.ml
- $(CAMLOPT) $(COMPFLAGS) -nopervasives -c pervasives.ml
-
-# camlinternalOO.cmi must be compiled with -nopervasives for applets
-camlinternalOO.cmi: camlinternalOO.mli
- $(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
-
-# labelled modules require the -nolabels flag
-labelled.cmo:
- $(MAKEREC) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) COMPILER=$(COMPILER) $(LABELLED:.ml=.cmo)
- touch $@
-labelled.cmx:
- $(MAKEREC) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmx)
- touch $@
-labelled.p.cmx:
- $(MAKEREC) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.p.cmx)
- touch $@
-
-# generic rules
.SUFFIXES: .mli .ml .cmi .cmo .cmx
.mli.cmi:
- $(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+ $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
.ml.cmo:
- $(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+ $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $<
.ml.cmx:
- $(CAMLOPT) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
-
-$(ALLOBJS) labelled.cmo std_exit.cmo: pervasives.cmi $(COMPILER)
-$(ALLOBJS:.cmo=.cmx) labelled.cmx std_exit.cmx: pervasives.cmi $(OPTCOMPILER)
-$(ALLOBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
-labelled.cmo labelled.cmx: $(LABELLED) $(LABELLED:.ml=.mli)
+ $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $<
+
+# Dependencies on the compiler
+$(OBJS) std_exit.cmo: $(COMPILER)
+$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
+$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER)
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER)
+
+# Dependencies on Pervasives (not tracked by ocamldep)
+$(OBJS) std_exit.cmo: pervasives.cmi
+$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi
+$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi
+$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi
+$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx
+$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx
clean::
rm -f *.cm* *.$(O) *.$(A)
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 5ed20e1c49..9514b95576 100644
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -70,13 +70,24 @@ let print_spec buf (key, spec, doc) =
| _ -> bprintf buf " %s %s\n" key doc
;;
+let help_action () = raise (Stop (Unknown "-help"));;
+
+let add_help speclist =
+ let add1 =
+ try ignore (assoc3 "-help" speclist); []
+ with Not_found ->
+ ["-help", Unit help_action, " Display this list of options"]
+ and add2 =
+ try ignore (assoc3 "--help" speclist); []
+ with Not_found ->
+ ["--help", Unit help_action, " Display this list of options"]
+ in
+ speclist @ (add1 @ add2)
+;;
+
let usage_b buf speclist errmsg =
bprintf buf "%s\n" errmsg;
- List.iter (print_spec buf) speclist;
- try ignore (assoc3 "-help" speclist)
- with Not_found -> bprintf buf " -help Display this list of options\n";
- try ignore (assoc3 "--help" speclist)
- with Not_found -> bprintf buf " --help Display this list of options\n";
+ List.iter (print_spec buf) (add_help speclist);
;;
let usage speclist errmsg =
@@ -202,3 +213,35 @@ let parse l f msg =
| Bad msg -> eprintf "%s" msg; exit 2;
| Help msg -> printf "%s" msg; exit 0;
;;
+
+let rec second_word s =
+ let len = String.length s in
+ let rec loop n =
+ if n >= len then len
+ else if s.[n] = ' ' then loop (n+1)
+ else n
+ in
+ try loop (String.index s ' ')
+ with Not_found -> len
+;;
+
+let max_arg_len cur (kwd, _, doc) =
+ max cur (String.length kwd + second_word doc)
+;;
+
+let add_padding len ksd =
+ match ksd with
+ | (_, Symbol _, _) -> ksd
+ | (kwd, spec, msg) ->
+ let cutcol = second_word msg in
+ let spaces = String.make (len - String.length kwd - cutcol) ' ' in
+ let prefix = String.sub msg 0 cutcol in
+ let suffix = String.sub msg cutcol (String.length msg - cutcol) in
+ (kwd, spec, prefix ^ spaces ^ suffix)
+;;
+
+let align speclist =
+ let completed = add_help speclist in
+ let len = List.fold_left max_arg_len 0 completed in
+ List.map (add_padding len) completed
+;;
diff --git a/stdlib/arg.mli b/stdlib/arg.mli
index a7258ada68..8203e83133 100644
--- a/stdlib/arg.mli
+++ b/stdlib/arg.mli
@@ -58,7 +58,6 @@ type spec =
call the function with the symbol *)
| Rest of (string -> unit) (** Stop interpreting keywords and call the
function with each remaining argument *)
-
(** The concrete type describing the behavior associated
with a keyword. *)
@@ -121,6 +120,13 @@ val usage : (key * spec * doc) list -> usage_msg -> unit
{!Arg.parse} prints in case of error.
[speclist] and [usage_msg] are the same as for [Arg.parse]. *)
+val align: (key * spec * doc) list -> (key * spec * doc) list;;
+(** Align the documentation strings by inserting spaces at the first
+ space, according to the length of the keyword. Use a
+ space as the first character in a doc string if you want to
+ align the whole string. The doc strings corresponding to
+ [Symbol] arguments are not aligned. *)
+
val current : int ref
(** Position (in {!Sys.argv}) of the argument being processed. You can
change this value, e.g. to force {!Arg.parse} to skip some arguments.
diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index dcde111ecd..cafec4444c 100644
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -11,6 +11,8 @@
(* *)
(***********************************************************************)
+(* $Id$ *)
+
(* Extensible buffers *)
type t =
@@ -27,6 +29,22 @@ let create n =
let contents b = String.sub b.buffer 0 b.position
+let sub b ofs len =
+ if ofs < 0 || len < 0 || ofs > b.position - len
+ then invalid_arg "Buffer.sub"
+ else begin
+ let r = String.create len in
+ String.blit b.buffer ofs r 0 len;
+ r
+ end
+;;
+
+let nth b ofs =
+ if ofs < 0 || ofs >= b.position then
+ invalid_arg "Buffer.nth"
+ else String.get b.buffer ofs
+;;
+
let length b = b.position
let clear b = b.position <- 0
@@ -87,9 +105,9 @@ let closing = function
| _ -> assert false;;
(* opening and closing: open and close characters, typically ( and )
- k balance of opening and closing chars
- s the string where we are searching
- start the index where we start the search *)
+ k: balance of opening and closing chars
+ s: the string where we are searching
+ start: the index where we start the search. *)
let advance_to_closing opening closing k s start =
let rec advance k i lim =
if i >= lim then raise Not_found else
@@ -110,7 +128,7 @@ let advance_to_non_alpha s start =
| _ -> i in
advance start (String.length s);;
-(* We are just at the beginning of an ident in s, starting at start *)
+(* We are just at the beginning of an ident in s, starting at start. *)
let find_ident s start =
match s.[start] with
(* Parenthesized ident ? *)
diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli
index 73e02e299b..6fc76148ad 100644
--- a/stdlib/buffer.mli
+++ b/stdlib/buffer.mli
@@ -11,6 +11,8 @@
(* *)
(***********************************************************************)
+(* $Id$ *)
+
(** Extensible string buffers.
This module implements string buffers that automatically expand
@@ -40,6 +42,16 @@ val contents : t -> string
(** Return a copy of the current contents of the buffer.
The buffer itself is unchanged. *)
+val sub : t -> int -> int -> string
+(** [Buffer.sub b off len] returns (a copy of) the substring of the
+current contents of the buffer [b] starting at offset [off] of length
+[len] bytes. May raise [Invalid_argument] if out of bounds request. The
+buffer itself is unaffected. *)
+
+val nth : t -> int -> char
+(** get the n-th character of the buffer. Raise [Invalid_argument] if
+index out of bounds *)
+
val length : t -> int
(** Return the number of characters currently contained in the buffer. *)
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 95f07456f4..fff08b49f5 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -54,185 +54,36 @@ let params = {
(**** Parameters ****)
let step = Sys.word_size / 16
-let first_bucket = 0
-let bucket_size = 32 (* Must be 256 or less *)
let initial_object_size = 2
-(**** Index ****)
-
-type label = int
-
-let label_count = ref 0
-
-let next label =
- incr label_count;
- let label = label + step in
- if label mod (step * bucket_size) = 0 then
- label + step * (65536 - bucket_size)
- else
- label
-
-let decode label =
- (label / 65536 / step, (label mod (step * bucket_size)) / step)
-
(**** Items ****)
-type item
+type item = DummyA | DummyB | DummyC of int
let dummy_item = (magic () : item)
-(**** Buckets ****)
-
-type bucket = item array
-
-let version = ref 0
-
-let set_bucket_version (bucket : bucket) =
- bucket.(bucket_size) <- (magic !version : item)
-
-let bucket_version bucket =
- (magic bucket.(bucket_size) : int)
-
-let bucket_list = ref []
-
-let empty_bucket = [| |]
-
-let new_bucket () =
- let bucket = Array.create (bucket_size + 1) dummy_item in
- set_bucket_version bucket;
- bucket_list := bucket :: !bucket_list;
- bucket
-
-let copy_bucket bucket =
- let bucket = Array.copy bucket in
- set_bucket_version bucket;
- bucket.(bucket_size) <- (magic !version : item);
- bucket_list := bucket :: !bucket_list;
- bucket
-
-(**** Make a clean bucket ****)
-
-let new_filled_bucket pos methods =
- let bucket = new_bucket () in
- List.iter
- (fun (lab, met) ->
- let (buck, elem) = decode lab in
- if buck = pos then
- bucket.(elem) <- (magic met : item))
- (List.rev methods);
- bucket
-
-(**** Bucket merging ****)
-
-let small_buckets = ref (Array.create 10 [| |])
-let small_bucket_count = ref 0
-
-let insert_bucket bucket =
- let length = Array.length !small_buckets in
- if !small_bucket_count >= length then begin
- let new_array = Array.create (2 * length) [| |] in
- Array.blit !small_buckets 0 new_array 0 length;
- small_buckets := new_array
- end;
- !small_buckets.(!small_bucket_count) <- bucket;
- incr small_bucket_count
-
-let remove_bucket n =
- !small_buckets.(n) <- !small_buckets.(!small_bucket_count - 1);
- decr small_bucket_count
-
-let bucket_used b =
- let n = ref 0 in
- for i = 0 to bucket_size - 1 do
- if b.(i) != dummy_item then incr n
- done;
- !n
-
-let small_bucket b = bucket_used b <= params.bucket_small_size
-
-exception Failed
-
-let rec except e =
- function
- [] -> []
- | e'::l -> if e == e' then l else e'::(except e l)
-
-let merge_buckets b1 b2 =
- for i = 0 to bucket_size - 1 do
- if
- (b2.(i) != dummy_item) && (b1.(i) != dummy_item) && (b2.(i) != b1.(i))
- then
- raise Failed
- done;
- for i = 0 to bucket_size - 1 do
- if b2.(i) != dummy_item then
- b1.(i) <- b2.(i)
- done;
- bucket_list := except b2 !bucket_list;
- b1
-
-let prng = Random.State.make [| 0 |];;
-
-let rec choose bucket i =
- if (i > 0) && (!small_bucket_count > 0) then begin
- let n = Random.State.int prng !small_bucket_count in
- if not (small_bucket !small_buckets.(n)) then begin
- remove_bucket n; choose bucket i
- end else
- try
- merge_buckets !small_buckets.(n) bucket
- with Failed ->
- choose bucket (i - 1)
- end else begin
- insert_bucket bucket;
- bucket
- end
-
-let compact b =
- if
- (b != empty_bucket) && (bucket_version b = !version) && (small_bucket b)
- then
- choose b params.retry_count
- else
- b
+(**** Types ****)
-let compact_buckets buckets =
- for i = first_bucket to Array.length buckets - 1 do
- buckets.(i) <- compact buckets.(i)
- done
+type tag
+type label = int
+type closure = item
+type t = DummyA | DummyB | DummyC of int
+type obj = t array
+external ret : (obj -> 'a) -> closure = "%identity"
(**** Labels ****)
-let first_label = first_bucket * 65536 * step
-
-let last_label = ref first_label
-let methods = Hashtbl.create 101
-
-let new_label () =
- let label = !last_label in
- last_label := next !last_label;
- label
-
-let new_method met =
- try
- Hashtbl.find methods met
- with Not_found ->
- let label = new_label () in
- Hashtbl.add methods met label;
- label
-
-let public_method_label met =
- try
- Hashtbl.find methods met
- with Not_found ->
- invalid_arg "Oo.public_method_label"
-
-let new_anonymous_method =
- new_label
-
-(**** Types ****)
-
-type obj = t array
+let public_method_label s : tag =
+ let accu = ref 0 in
+ for i = 0 to String.length s - 1 do
+ accu := 223 * !accu + Char.code s.[i]
+ done;
+ (* reduce to 31 bits *)
+ accu := !accu land (1 lsl 31 - 1);
+ (* make it signed for 64 bits architectures *)
+ let tag = if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu in
+ (* Printf.eprintf "%s = %d\n" s tag; flush stderr; *)
+ magic tag
(**** Sparse array ****)
@@ -247,7 +98,7 @@ type labs = bool Labs.t
(* The compiler assumes that the first field of this structure is [size]. *)
type table =
{ mutable size: int;
- mutable buckets: bucket array;
+ mutable methods: closure array;
mutable methods_by_name: meths;
mutable methods_by_label: labs;
mutable previous_states:
@@ -258,20 +109,31 @@ type table =
mutable initializers: (obj -> unit) list }
let dummy_table =
- { buckets = [| |];
+ { methods = [| dummy_item |];
methods_by_name = Meths.empty;
methods_by_label = Labs.empty;
previous_states = [];
hidden_meths = [];
vars = Vars.empty;
initializers = [];
- size = initial_object_size }
+ size = 0 }
let table_count = ref 0
-let new_table () =
+let null_item : item = Obj.obj (Obj.field (Obj.repr 0n) 1)
+
+let rec fit_size n =
+ if n <= 2 then n else
+ fit_size ((n+1)/2) * 2
+
+let new_table pub_labels =
incr table_count;
- { buckets = [| |];
+ let len = Array.length pub_labels in
+ let methods = Array.create (len*2+2) null_item in
+ methods.(0) <- magic len;
+ methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1);
+ for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done;
+ { methods = methods;
methods_by_name = Meths.empty;
methods_by_label = Labs.empty;
previous_states = [];
@@ -281,40 +143,42 @@ let new_table () =
size = initial_object_size }
let resize array new_size =
- let old_size = Array.length array.buckets in
+ let old_size = Array.length array.methods in
if new_size > old_size then begin
- let new_buck = Array.create new_size empty_bucket in
- Array.blit array.buckets 0 new_buck 0 old_size;
- array.buckets <- new_buck
+ let new_buck = Array.create new_size null_item in
+ Array.blit array.methods 0 new_buck 0 old_size;
+ array.methods <- new_buck
end
let put array label element =
- let (buck, elem) = decode label in
- resize array (buck + 1);
- let bucket = ref (array.buckets.(buck)) in
- if !bucket == empty_bucket then begin
- bucket := new_bucket ();
- array.buckets.(buck) <- !bucket
- end;
- !bucket.(elem) <- element
+ resize array (label + 1);
+ array.methods.(label) <- element
(**** Classes ****)
let method_count = ref 0
let inst_var_count = ref 0
-type t
+(* type t *)
type meth = item
+let new_method table =
+ let index = Array.length table.methods in
+ resize table (index + 1);
+ index
+
let get_method_label table name =
try
Meths.find name table.methods_by_name
with Not_found ->
- let label = new_anonymous_method () in
+ let label = new_method table in
table.methods_by_name <- Meths.add name label table.methods_by_name;
table.methods_by_label <- Labs.add label true table.methods_by_label;
label
+let get_method_labels table names =
+ Array.map (get_method_label table) names
+
let set_method table label element =
incr method_count;
if Labs.find label table.methods_by_label then
@@ -323,9 +187,8 @@ let set_method table label element =
table.hidden_meths <- (label, element) :: table.hidden_meths
let get_method table label =
- try List.assoc label table.hidden_meths with Not_found ->
- let (buck, elem) = decode label in
- table.buckets.(buck).(elem)
+ try List.assoc label table.hidden_meths
+ with Not_found -> table.methods.(label)
let to_list arr =
if arr == magic 0 then [] else Array.to_list arr
@@ -403,25 +266,39 @@ let new_variables table names =
let get_variable table name =
Vars.find name table.vars
+let get_variables table names =
+ Array.map (get_variable table) names
+
let add_initializer table f =
table.initializers <- f::table.initializers
+(*
+module Keys = Map.Make(struct type t = tag array let compare = compare end)
+let key_map = ref Keys.empty
+let get_key tags : item =
+ try magic (Keys.find tags !key_map : tag array)
+ with Not_found ->
+ key_map := Keys.add tags tags !key_map;
+ magic tags
+*)
+
let create_table public_methods =
- let table = new_table () in
- if public_methods != magic 0 then
- Array.iter
- (function met ->
- let lab = new_method met in
- table.methods_by_name <- Meths.add met lab table.methods_by_name;
- table.methods_by_label <- Labs.add lab true table.methods_by_label)
- public_methods;
+ if public_methods == magic 0 then new_table [||] else
+ (* [public_methods] must be in ascending order for bytecode *)
+ let tags = Array.map public_method_label public_methods in
+ let table = new_table tags in
+ Array.iteri
+ (fun i met ->
+ let lab = i*2+2 in
+ table.methods_by_name <- Meths.add met lab table.methods_by_name;
+ table.methods_by_label <- Labs.add lab true table.methods_by_label)
+ public_methods;
table
let init_class table =
inst_var_count := !inst_var_count + table.size - 1;
- if params.compact_table then
- compact_buckets table.buckets;
- table.initializers <- List.rev table.initializers
+ table.initializers <- List.rev table.initializers;
+ resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
narrow cla vals virt_meths concr_meths;
@@ -451,7 +328,7 @@ let create_object table =
(* XXX Appel de [obj_block] *)
let obj = Obj.new_block Obj.object_tag table.size in
(* XXX Appel de [caml_modify] *)
- Obj.set_field obj 0 (Obj.repr table.buckets);
+ Obj.set_field obj 0 (Obj.repr table.methods);
set_id obj last_id;
(Obj.obj obj)
@@ -460,7 +337,7 @@ let create_object_opt obj_0 table =
(* XXX Appel de [obj_block] *)
let obj = Obj.new_block Obj.object_tag table.size in
(* XXX Appel de [caml_modify] *)
- Obj.set_field obj 0 (Obj.repr table.buckets);
+ Obj.set_field obj 0 (Obj.repr table.methods);
set_id obj last_id;
(Obj.obj obj)
end
@@ -490,17 +367,20 @@ let create_object_and_run_initializers obj_0 table =
end
(* Equivalent primitive below
-let send obj lab =
- let (buck, elem) = decode lab in
- (magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
+let sendself obj lab =
+ (magic obj : (obj -> t) array array).(0).(lab) obj
*)
-external send : obj -> label -> 'a = "%send"
+external send : obj -> tag -> 'a = "%send"
+external sendcache : obj -> tag -> t -> int -> 'a = "%sendcache"
+external sendself : obj -> label -> 'a = "%sendself"
+external get_public_method : obj -> tag -> closure
+ = "caml_get_public_method" "noalloc"
(**** table collection access ****)
-type tables = Empty | Cons of table * tables * tables
+type tables = Empty | Cons of closure * tables * tables
type mut_tables =
- {key: table; mutable data: tables; mutable next: tables}
+ {key: closure; mutable data: tables; mutable next: tables}
external mut : tables -> mut_tables = "%identity"
let build_path n keys tables =
@@ -533,34 +413,61 @@ let lookup_tables root keys =
(**** builtin methods ****)
-type closure = item
-external ret : (obj -> 'a) -> closure = "%identity"
-
let get_const x = ret (fun obj -> x)
let get_var n = ret (fun obj -> Array.unsafe_get obj n)
-let get_env e n = ret (fun obj -> Obj.field (Array.unsafe_get obj e) n)
-let get_meth n = ret (fun obj -> send obj n)
+let get_env e n =
+ ret (fun obj ->
+ Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)
+let get_meth n = ret (fun obj -> sendself obj n)
let set_var n = ret (fun obj x -> Array.unsafe_set obj n x)
let app_const f x = ret (fun obj -> f x)
let app_var f n = ret (fun obj -> f (Array.unsafe_get obj n))
-let app_env f e n = ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n))
-let app_meth f n = ret (fun obj -> f (send obj n))
+let app_env f e n =
+ ret (fun obj ->
+ f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
+let app_meth f n = ret (fun obj -> f (sendself obj n))
let app_const_const f x y = ret (fun obj -> f x y)
let app_const_var f x n = ret (fun obj -> f x (Array.unsafe_get obj n))
-let app_const_meth f x n = ret (fun obj -> f x (send obj n))
+let app_const_meth f x n = ret (fun obj -> f x (sendself obj n))
let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
-let app_meth_const f n x = ret (fun obj -> f (send obj n) x)
+let app_meth_const f n x = ret (fun obj -> f (sendself obj n) x)
let app_const_env f x e n =
- ret (fun obj -> f x (Obj.field (Array.unsafe_get obj e) n))
+ ret (fun obj ->
+ f x (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
let app_env_const f e n x =
- ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n) x)
-let meth_app_const n x = ret (fun obj -> (send obj n) x)
+ ret (fun obj ->
+ f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) x)
+let meth_app_const n x = ret (fun obj -> (sendself obj n) x)
let meth_app_var n m =
- ret (fun obj -> (send obj n) (Array.unsafe_get obj m))
+ ret (fun obj -> (sendself obj n) (Array.unsafe_get obj m))
let meth_app_env n e m =
- ret (fun obj -> (send obj n) (Obj.field (Array.unsafe_get obj e) m))
+ ret (fun obj -> (sendself obj n)
+ (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) m))
let meth_app_meth n m =
- ret (fun obj -> (send obj n) (send obj m))
+ ret (fun obj -> (sendself obj n) (sendself obj m))
+let send_const m x c =
+ ret (fun obj -> sendcache x m (Array.unsafe_get obj 0) c)
+let send_var m n c =
+ ret (fun obj ->
+ sendcache (Obj.magic (Array.unsafe_get obj n) : obj) m
+ (Array.unsafe_get obj 0) c)
+let send_env m e n c =
+ ret (fun obj ->
+ sendcache
+ (Obj.magic (Array.unsafe_get
+ (Obj.magic (Array.unsafe_get obj e) : obj) n) : obj)
+ m (Array.unsafe_get obj 0) c)
+let send_meth m n c =
+ ret (fun obj ->
+ sendcache (sendself obj n) m (Array.unsafe_get obj 0) c)
+let new_cache table =
+ let n = new_method table in
+ let n =
+ if n mod 2 = 0 || n > 2 + magic table.methods.(1) * 16 / Sys.word_size
+ then n else new_method table
+ in
+ table.methods.(n) <- Obj.magic 0;
+ n
type impl =
GetConst
@@ -583,23 +490,27 @@ type impl =
| MethAppVar
| MethAppEnv
| MethAppMeth
- | Closure of Obj.t
+ | SendConst
+ | SendVar
+ | SendEnv
+ | SendMeth
+ | Closure of closure
-let method_impl i arr =
+let method_impl table i arr =
let next () = incr i; magic arr.(!i) in
match next() with
- GetConst -> let x : t = next() in ret (fun obj -> x)
+ GetConst -> let x : t = next() in get_const x
| GetVar -> let n = next() in get_var n
| GetEnv -> let e = next() and n = next() in get_env e n
| GetMeth -> let n = next() in get_meth n
| SetVar -> let n = next() in set_var n
- | AppConst -> let f = next() and x = next() in ret (fun obj -> f x)
+ | AppConst -> let f = next() and x = next() in app_const f x
| AppVar -> let f = next() and n = next () in app_var f n
| AppEnv ->
let f = next() and e = next() and n = next() in app_env f e n
| AppMeth -> let f = next() and n = next () in app_meth f n
| AppConstConst ->
- let f = next() and x = next() and y = next() in ret (fun obj -> f x y)
+ let f = next() and x = next() and y = next() in app_const_const f x y
| AppConstVar ->
let f = next() and x = next() and n = next() in app_const_var f x n
| AppConstEnv ->
@@ -622,12 +533,21 @@ let method_impl i arr =
let n = next() and e = next() and m = next() in meth_app_env n e m
| MethAppMeth ->
let n = next() and m = next() in meth_app_meth n m
+ | SendConst ->
+ let m = next() and x = next() in send_const m x (new_cache table)
+ | SendVar ->
+ let m = next() and n = next () in send_var m n (new_cache table)
+ | SendEnv ->
+ let m = next() and e = next() and n = next() in
+ send_env m e n (new_cache table)
+ | SendMeth ->
+ let m = next() and n = next () in send_meth m n (new_cache table)
| Closure _ as clo -> magic clo
let set_methods table methods =
let len = Array.length methods and i = ref 0 in
while !i < len do
- let label = methods.(!i) and clo = method_impl i methods in
+ let label = methods.(!i) and clo = method_impl table i methods in
set_method table label clo;
incr i
done
@@ -635,35 +555,8 @@ let set_methods table methods =
(**** Statistics ****)
type stats =
- { classes: int; labels: int; methods: int; inst_vars: int; buckets: int;
- distrib : int array; small_bucket_count: int; small_bucket_max: int }
-
-let distrib () =
- let d = Array.create 32 0 in
- List.iter
- (function b ->
- let n = bucket_used b in
- d.(n - 1) <- d.(n - 1) + 1)
- !bucket_list;
- d
+ { classes: int; methods: int; inst_vars: int; }
let stats () =
- { classes = !table_count; labels = !label_count;
- methods = !method_count; inst_vars = !inst_var_count;
- buckets = List.length !bucket_list; distrib = distrib ();
- small_bucket_count = !small_bucket_count;
- small_bucket_max = Array.length !small_buckets }
-
-let sort_buck lst =
- List.map snd
- (Sort.list (fun (n, _) (n', _) -> n <= n')
- (List.map (function b -> (bucket_used b, b)) lst))
-
-let show_buckets () =
- List.iter
- (function b ->
- for i = 0 to bucket_size - 1 do
- print_char (if b.(i) == dummy_item then '.' else '*')
- done;
- print_newline ())
- (sort_buck !bucket_list)
+ { classes = !table_count;
+ methods = !method_count; inst_vars = !inst_var_count; }
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index 0195d465f5..8b6c980f6a 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -17,22 +17,23 @@
All functions in this module are for system use only, not for the
casual user. *)
-(** {6 Methods} *)
-
-type label
-val new_method : string -> label
-val public_method_label : string -> label
-
(** {6 Classes} *)
+type tag
+type label
type table
type meth
type t
type obj
+type closure
+val public_method_label : string -> tag
+val new_method : table -> label
val new_variable : table -> string -> int
val new_variables : table -> string array -> int
val get_variable : table -> string -> int
+val get_variables : table -> string array -> int array
val get_method_label : table -> string -> label
+val get_method_labels : table -> string array -> label array
val get_method : table -> label -> meth
val set_method : table -> label -> meth -> unit
val set_methods : table -> label array -> unit
@@ -60,17 +61,19 @@ val create_object_opt : obj -> table -> obj
val run_initializers : obj -> table -> unit
val run_initializers_opt : obj -> obj -> table -> obj
val create_object_and_run_initializers : obj -> table -> obj
-external send : obj -> label -> t = "%send"
+external send : obj -> tag -> t = "%send"
+external sendcache : obj -> tag -> t -> int -> t = "%sendcache"
+external sendself : obj -> label -> t = "%sendself"
+external get_public_method : obj -> tag -> closure
+ = "caml_get_public_method" "noalloc"
(** {6 Table cache} *)
type tables
-val lookup_tables : tables -> table array -> tables
+val lookup_tables : tables -> closure array -> tables
(** {6 Builtins to reduce code size} *)
-open Obj
-type closure
val get_const : t -> closure
val get_var : int -> closure
val get_env : int -> int -> closure
@@ -91,6 +94,10 @@ val meth_app_const : label -> t -> closure
val meth_app_var : label -> int -> closure
val meth_app_env : label -> int -> int -> closure
val meth_app_meth : label -> label -> closure
+val send_const : tag -> obj -> int -> closure
+val send_var : tag -> int -> int -> closure
+val send_env : tag -> int -> int -> int -> closure
+val send_meth : tag -> label -> int -> closure
type impl =
GetConst
@@ -113,10 +120,15 @@ type impl =
| MethAppVar
| MethAppEnv
| MethAppMeth
- | Closure of t
+ | SendConst
+ | SendVar
+ | SendEnv
+ | SendMeth
+ | Closure of closure
(** {6 Parameters} *)
+(* currently disabled *)
type params =
{ mutable compact_table : bool;
mutable copy_parent : bool;
@@ -130,12 +142,6 @@ val params : params
type stats =
{ classes : int;
- labels : int;
methods : int;
- inst_vars : int;
- buckets : int;
- distrib : int array;
- small_bucket_count : int;
- small_bucket_max : int }
+ inst_vars : int }
val stats : unit -> stats
-val show_buckets : unit -> unit
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index 82dce717bd..7d6887eaf4 100644
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -28,11 +28,9 @@ let generic_quote quotequote s =
module Unix = struct
let current_dir_name = "."
let parent_dir_name = ".."
- let concat dirname filename =
- let l = String.length dirname in
- if l = 0 || dirname.[l-1] = '/'
- then dirname ^ filename
- else dirname ^ "/" ^ filename
+ let dir_sep = "/"
+ let is_dir_sep s i = s.[i] = '/'
+ let rindex_dir_sep s = String.rindex s '/'
let is_relative n = String.length n < 1 || n.[0] <> '/';;
let is_implicit n =
is_relative n
@@ -42,19 +40,6 @@ module Unix = struct
String.length name >= String.length suff &&
String.sub name (String.length name - String.length suff)
(String.length suff) = suff
- let basename name =
- try
- let p = String.rindex name '/' + 1 in
- String.sub name p (String.length name - p)
- with Not_found ->
- name
- let dirname name =
- try
- match String.rindex name '/' with
- 0 -> "/"
- | n -> String.sub name 0 n
- with Not_found ->
- "."
let temporary_directory =
try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
let quote = generic_quote "'\\''"
@@ -63,11 +48,14 @@ end
module Win32 = struct
let current_dir_name = "."
let parent_dir_name = ".."
- let concat dirname filename =
- let l = String.length dirname in
- if l = 0 || (let c = dirname.[l-1] in c = '/' || c = '\\' || c = ':')
- then dirname ^ filename
- else dirname ^ "\\" ^ filename
+ let dir_sep = "\\"
+ let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':'
+ let rindex_dir_sep s =
+ let rec pos i =
+ if i < 0 then raise Not_found
+ else if (let c = s.[i] in c = '/' || c = '\\' || c = ':') then i
+ else pos (i - 1)
+ in pos (String.length s - 1)
let is_relative n =
(String.length n < 1 || n.[0] <> '/')
&& (String.length n < 1 || n.[0] <> '\\')
@@ -83,29 +71,6 @@ module Win32 = struct
(let s = String.sub name (String.length name - String.length suff)
(String.length suff) in
String.lowercase s = String.lowercase suff)
- let rindexsep s =
- let rec pos i =
- if i < 0 then raise Not_found
- else if (let c = s.[i] in c = '/' || c = '\\' || c = ':') then i
- else pos (i - 1)
- in pos (String.length s - 1)
- let basename name =
- try
- let p = rindexsep name + 1 in
- String.sub name p (String.length name - p)
- with Not_found ->
- name
- let dirname name =
- try
- match rindexsep name with
- 0 -> "\\"
- | n ->
- let n =
- if name.[n] = ':' || (n > 0 && name.[n-1] = ':')
- then n+1 else n in
- String.sub name 0 n
- with Not_found ->
- "."
let temporary_directory =
try Sys.getenv "TEMP" with Not_found -> "."
let quote s =
@@ -127,57 +92,67 @@ end
module Cygwin = struct
let current_dir_name = "."
let parent_dir_name = ".."
- let concat dirname filename =
- let l = String.length dirname in
- if l = 0 || (let c = dirname.[l-1] in c = '/' || c = '\\' || c = ':')
- then dirname ^ filename
- else dirname ^ "/" ^ filename
+ let dir_sep = "/"
+ let is_dir_sep = Win32.is_dir_sep
+ let rindex_dir_sep = Win32.rindex_dir_sep
let is_relative = Win32.is_relative
let is_implicit = Win32.is_implicit
let check_suffix = Win32.check_suffix
- let basename = Win32.basename
- let dirname name =
- try
- match Win32.rindexsep name with
- 0 -> "/"
- | n ->
- let n =
- if name.[n] = ':' || (n > 0 && name.[n-1] = ':')
- then n+1 else n in
- String.sub name 0 n
- with Not_found ->
- "."
let temporary_directory = Unix.temporary_directory
let quote = Unix.quote
end
-let (current_dir_name, parent_dir_name, concat, is_relative, is_implicit,
- check_suffix, basename, dirname, temporary_directory, quote) =
+let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep,
+ is_relative, is_implicit, check_suffix, temporary_directory, quote) =
match Sys.os_type with
"Unix" ->
- (Unix.current_dir_name, Unix.parent_dir_name, Unix.concat,
+ (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
+ Unix.is_dir_sep, Unix.rindex_dir_sep,
Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
- Unix.basename, Unix.dirname, Unix.temporary_directory, Unix.quote)
+ Unix.temporary_directory, Unix.quote)
| "Win32" ->
- (Win32.current_dir_name, Win32.parent_dir_name, Win32.concat,
+ (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
+ Win32.is_dir_sep, Win32.rindex_dir_sep,
Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
- Win32.basename, Win32.dirname, Win32.temporary_directory, Win32.quote)
+ Win32.temporary_directory, Win32.quote)
| "Cygwin" ->
- (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.concat,
+ (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
+ Cygwin.is_dir_sep, Cygwin.rindex_dir_sep,
Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
- Cygwin.basename, Cygwin.dirname,
Cygwin.temporary_directory, Cygwin.quote)
| _ -> assert false
+let concat dirname filename =
+ let l = String.length dirname in
+ if l = 0 || is_dir_sep dirname (l-1)
+ then dirname ^ filename
+ else dirname ^ dir_sep ^ filename
+
+let basename name =
+ try
+ let p = rindex_dir_sep name + 1 in
+ String.sub name p (String.length name - p)
+ with Not_found ->
+ name
+
+let dirname name =
+ try
+ match rindex_dir_sep name with
+ 0 -> dir_sep
+ | n -> String.sub name 0 n
+ with Not_found ->
+ current_dir_name
+
let chop_suffix name suff =
let n = String.length name - String.length suff in
if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n
let chop_extension name =
- try
- String.sub name 0 (String.rindex name '.')
- with Not_found ->
- invalid_arg "Filename.chop_extension"
+ let rec search_dot i =
+ if i < 0 || is_dir_sep name i then invalid_arg "Filename.chop_extension"
+ else if name.[i] = '.' then String.sub name 0 i
+ else search_dot (i - 1) in
+ search_dot (String.length name - 1)
external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
external close_desc: int -> unit = "caml_sys_close"
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index 2d0d34396d..086775f5e9 100644
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -48,10 +48,11 @@ val chop_suffix : string -> string -> string
val chop_extension : string -> string
(** Return the given file name without its extension. The extension
- is the shortest suffix starting with a period, [.xyz] for instance.
+ is the shortest suffix starting with a period and not including
+ a directory separator, [.xyz] for instance.
Raise [Invalid_argument] if the given name does not contain
- a period. *)
+ an extension. *)
val basename : string -> string
(** Split a file name into directory name / base file name.
diff --git a/stdlib/format.mli b/stdlib/format.mli
index a8c83bd1b6..3526e2365b 100644
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -20,6 +20,9 @@
at specified break hints, and indents lines according to the box
structure.
+ For a gentle introduction to the basics of prety-printing using
+ [Format], read the FAQ at [http://caml.inria.fr/FAQ/format-eng.html].
+
Warning: the material output by the following functions is delayed
in the pretty-printer queue in order to compute the proper line
breaking. Hence, you should not mix calls to the printing functions
@@ -584,7 +587,9 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
[nspaces] and [offset] parameters of the break may be
optionally specified with the following syntax:
the [<] character, followed by an integer [nspaces] value,
- then an integer offset, and a closing [>] character.
+ then an integer offset, and a closing [>] character.
+ If no parameters are provided, the good break defaults to a
+ space.
- [@?]: flush the pretty printer as with [print_flush ()].
This is equivalent to the conversion [%!].
- [@.]: flush the pretty printer and output a new line, as with
diff --git a/stdlib/gc.ml b/stdlib/gc.ml
index e4a15aea66..7299ff867c 100644
--- a/stdlib/gc.ml
+++ b/stdlib/gc.ml
@@ -78,6 +78,7 @@ let allocated_bytes () =
;;
external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register";;
+external finalise_release : unit -> unit = "caml_final_release";;
type alarm = bool ref;;
diff --git a/stdlib/gc.mli b/stdlib/gc.mli
index 491faab393..bafa8ed9f7 100644
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -188,14 +188,15 @@ val finalise : ('a -> unit) -> 'a -> unit
be registered for the same value, or even several instances of the
same function. Each instance will be called once (or never,
if the program terminates before [v] becomes unreachable).
-
-
- A number of pitfalls are associated with finalised values:
- finalisation functions are called asynchronously, sometimes
- even during the execution of other finalisation functions.
- In a multithreaded program, finalisation functions are called
- from any thread, thus they must not acquire any mutex.
+ The GC will call the finalisation functions in the order of
+ deallocation. When several values become unreachable at the
+ same time (i.e. during the same GC cycle), the finalisation
+ functions will be called in the reverse order of the corresponding
+ calls to [finalise]. If [finalise] is called in the same order
+ as the values are allocated, that means each value is finalised
+ before the values it depends upon. Of course, this becomes
+ false if additional dependencies are introduced by assignments.
Anything reachable from the closure of finalisation functions
is considered reachable, so the following code will not work
@@ -232,10 +233,14 @@ val finalise : ('a -> unit) -> 'a -> unit
The results of calling {!String.make}, {!String.create},
{!Array.make}, and {!Pervasives.ref} are guaranteed to be
- heap-allocated and non-constant
- except when the length argument is [0].
+ heap-allocated and non-constant except when the length argument is [0].
*)
+val finalise_release : unit -> unit;;
+(** A finalisation function may call [finalise_release] to tell the
+ GC that it can launch the next finalisation function without waiting
+ for the current one to return. *)
+
type alarm
(** An alarm is a piece of data that calls a user function at the end of
each major GC cycle. The following functions are provided to create
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index 0169f747ae..225aa6be78 100644
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -44,6 +44,8 @@ let copy h =
{ size = h.size;
data = Array.copy h.data }
+let length h = h.size
+
let resize hashfun tbl =
let odata = tbl.data in
let osize = Array.length odata in
@@ -184,6 +186,7 @@ module type S =
val mem : 'a t -> key -> bool
val iter: (key -> 'a -> unit) -> 'a t -> unit
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val length: 'a t -> int
end
module Make(H: HashedType): (S with type key = H.t) =
@@ -272,4 +275,7 @@ module Make(H: HashedType): (S with type key = H.t) =
let iter = iter
let fold = fold
+ let length = length
end
+
+(* eof $Id$ *)
diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index fcb296a7ce..d6434ade79 100644
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -35,6 +35,7 @@ val create : int -> ('a, 'b) t
val clear : ('a, 'b) t -> unit
(** Empty a hash table. *)
+
val add : ('a, 'b) t -> 'a -> 'b -> unit
(** [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl].
Previous bindings for [x] are not removed, but simply
@@ -91,6 +92,12 @@ val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
the most recent binding is passed first. *)
+val length : ('a, 'b) t -> int
+(** [Hashtbl.length tbl] returns the number of bindings in [tbl].
+ Multiple bindings are counted multiply, so [Hashtbl.length]
+ gives the number of times [Hashtbl.iter] calls it first argument. *)
+
+
(** {6 Functorial interface} *)
@@ -130,6 +137,7 @@ module type S =
val mem : 'a t -> key -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val length : 'a t -> int
end
(** The output signature of the functor {!Hashtbl.Make}. *)
diff --git a/stdlib/map.ml b/stdlib/map.ml
index 26c4d23c00..81b3396f33 100644
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -24,6 +24,7 @@ module type S =
type key
type +'a t
val empty: 'a t
+ val is_empty: 'a t -> bool
val add: key -> 'a -> 'a t -> 'a t
val find: key -> 'a t -> 'a
val remove: key -> 'a t -> 'a t
@@ -32,6 +33,8 @@ module type S =
val map: ('a -> 'b) -> 'a t -> 'b t
val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+ val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
end
module Make(Ord: OrderedType) = struct
@@ -42,8 +45,6 @@ module Make(Ord: OrderedType) = struct
Empty
| Node of 'a t * key * 'a * 'a t * int
- let empty = Empty
-
let height = function
Empty -> 0
| Node(_,_,_,_,h) -> h
@@ -82,6 +83,10 @@ module Make(Ord: OrderedType) = struct
end else
Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+ let empty = Empty
+
+ let is_empty = function Empty -> true | _ -> false
+
let rec add x data = function
Empty ->
Node(Empty, x, data, Empty, 1)
@@ -158,4 +163,36 @@ module Make(Ord: OrderedType) = struct
| Node(l, v, d, r, _) ->
fold f l (f v d (fold f r accu))
+ type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
+
+ let rec cons_enum m e =
+ match m with
+ Empty -> e
+ | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
+
+ let compare cmp m1 m2 =
+ let rec compare_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> 0
+ | (End, _) -> -1
+ | (_, End) -> 1
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ let c = Ord.compare v1 v2 in
+ if c <> 0 then c else
+ let c = cmp d1 d2 in
+ if c <> 0 then c else
+ compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ in compare_aux (cons_enum m1 End) (cons_enum m2 End)
+
+ let equal cmp m1 m2 =
+ let rec equal_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> true
+ | (End, _) -> false
+ | (_, End) -> false
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ Ord.compare v1 v2 = 0 && cmp d1 d2 &&
+ equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ in equal_aux (cons_enum m1 End) (cons_enum m2 End)
+
end
diff --git a/stdlib/map.mli b/stdlib/map.mli
index ea8cc68f4f..71d6e269c1 100644
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -49,6 +49,9 @@ module type S =
val empty: 'a t
(** The empty map. *)
+ val is_empty: 'a t -> bool
+ (** Test whether a map is empty or not. *)
+
val add: key -> 'a -> 'a t -> 'a t
(** [add x y m] returns a map containing the same bindings as
[m], plus a binding of [x] to [y]. If [x] was already bound
@@ -90,6 +93,16 @@ module type S =
where [k1 ... kN] are the keys of all bindings in [m]
(in increasing order), and [d1 ... dN] are the associated data. *)
+ val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+ (** Total ordering between maps. The first argument is a total ordering
+ used to compare data associated with equal keys in the two maps. *)
+
+ val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are
+ equal, that is, contain equal keys and associate them with
+ equal data. [cmp] is the equality predicate used to compare
+ the data associated with the keys. *)
+
end
(** Output signature of the functor {!Map.Make}. *)
diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index 6a690470cb..fbf848cba8 100644
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -38,6 +38,7 @@ module Hashtbl : sig
val fold :
f:(key:'a -> data:'b -> 'c -> 'c) ->
('a, 'b) t -> init:'c -> 'c
+ val length : ('a, 'b) t -> int
module type HashedType = Hashtbl.HashedType
module type S =
sig
@@ -56,6 +57,7 @@ module Hashtbl : sig
val fold :
f:(key:key -> data:'a -> 'b -> 'b) ->
'a t -> init:'b -> 'b
+ val length : 'a t -> int
end
module Make : functor (H : HashedType) -> S with type key = H.t
val hash : 'a -> int
@@ -70,6 +72,7 @@ module Map : sig
type key
and (+'a) t
val empty : 'a t
+ val is_empty: 'a t -> bool
val add : key:key -> data:'a -> 'a t -> 'a t
val find : key -> 'a t -> 'a
val remove : key -> 'a t -> 'a t
@@ -80,7 +83,9 @@ module Map : sig
val fold :
f:(key:key -> data:'a -> 'b -> 'b) ->
'a t -> init:'b -> 'b
- end
+ val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int
+ val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ end
module Make : functor (Ord : OrderedType) -> S with type key = Ord.t
end
@@ -113,6 +118,7 @@ module Set : sig
val min_elt : t -> elt
val max_elt : t -> elt
val choose : t -> elt
+ val split: elt -> t -> t * bool * t
end
module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t
end
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
index e8795d8573..c9ec64ae44 100644
--- a/stdlib/oo.ml
+++ b/stdlib/oo.ml
@@ -15,5 +15,5 @@
let copy = CamlinternalOO.copy
external id : < .. > -> int = "%field1"
-let new_method = CamlinternalOO.new_method
+let new_method = CamlinternalOO.public_method_label
let public_method_label = CamlinternalOO.public_method_label
diff --git a/stdlib/oo.mli b/stdlib/oo.mli
index c18bfa51e4..b3111ce857 100644
--- a/stdlib/oo.mli
+++ b/stdlib/oo.mli
@@ -25,5 +25,5 @@ external id : < .. > -> int = "%field1"
(**/**)
(** For internal use (CamlIDL) *)
-val new_method : string -> CamlinternalOO.label
-val public_method_label : string -> CamlinternalOO.label
+val new_method : string -> CamlinternalOO.tag
+val public_method_label : string -> CamlinternalOO.tag
diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
index 6045c18d36..c6dc8e3212 100644
--- a/stdlib/parsing.mli
+++ b/stdlib/parsing.mli
@@ -30,7 +30,7 @@ val rhs_start : int -> int
(** Same as {!Parsing.symbol_start} and {!Parsing.symbol_end}, but
return the offset of the string matching the [n]th item on the
right-hand side of the rule, where [n] is the integer parameter
- to [lhs_start] and [lhs_end]. [n] is 1 for the leftmost item. *)
+ to [rhs_start] and [rhs_end]. [n] is 1 for the leftmost item. *)
val rhs_end : int -> int
(** See {!Parsing.rhs_start}. *)
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index 2561cc4cab..0b678ca28f 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -603,7 +603,9 @@ val output_byte : out_channel -> int -> unit
256. *)
val output_binary_int : out_channel -> int -> unit
-(** Write one integer in binary format on the given output channel.
+(** Write one integer in binary format (4 bytes, big-endian)
+ on the given output channel.
+ The given integer is taken modulo 2{^32}.
The only reliable way to read it back is through the
{!Pervasives.input_binary_int} function. The format is compatible across
all machines for a given version of Objective Caml. *)
@@ -623,7 +625,9 @@ val seek_out : out_channel -> int -> unit
the behavior is unspecified. *)
val pos_out : out_channel -> int
-(** Return the current writing position for the given channel. *)
+(** Return the current writing position for the given channel. Does
+ not work on channels opened with the [Open_append] flag (returns
+ unspecified results). *)
val out_channel_length : out_channel -> int
(** Return the total length (number of characters) of the
@@ -713,8 +717,8 @@ val input_byte : in_channel -> int
Raise [End_of_file] if an end of file was reached. *)
val input_binary_int : in_channel -> int
-(** Read an integer encoded in binary format from the given input
- channel. See {!Pervasives.output_binary_int}.
+(** Read an integer encoded in binary format (4 bytes, big-endian)
+ from the given input channel. See {!Pervasives.output_binary_int}.
Raise [End_of_file] if an end of file was reached while reading the
integer. *)
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 7413e21493..78adcc706a 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -115,8 +115,9 @@ type scanbuf = {
file_name : file_name;
};;
-(* Reads a new character from input buffer, sets the end of file
- condition if necessary. *)
+(* Reads a new character from input buffer. Next_char never fails,
+ even in case of end of input: it then simply sets the end of file
+ condition. *)
let next_char ib =
try
let c = ib.get_next_char () in
@@ -264,8 +265,9 @@ let check_char_in range ib =
(* Checking that [c] is indeed in the input, then skip it. *)
let check_char ib c =
let ci = Scanning.checked_peek_char ib in
- if ci == c then Scanning.next_char ib else
- bad_input (Printf.sprintf "looking for %C, found %C" c ci);;
+ if ci != c
+ then bad_input (Printf.sprintf "looking for %C, found %C" c ci)
+ else Scanning.next_char ib;;
(* Extracting tokens from ouput token buffer. *)
@@ -315,11 +317,20 @@ let token_int64 conv ib = int64_of_string (token_int_literal conv ib);;
(* Scanning numbers. *)
-(* The decimal case is optimized. *)
+(* Digits scanning functions suppose that one character has been
+ checked and is available, since they return at end of file with the
+ currently found token selected. The digits scanning functions scan
+ a possibly empty sequence of digits, (hence a successful scanning
+ from one of those functions does not imply that the token is a
+ well-formed number: to get a true number, it is mandatory to check
+ that at least one digit is available before calling a digit
+ scanning function). *)
+
+(* The decimal case is treated especially for optimization purposes. *)
let scan_decimal_digits max ib =
let rec loop inside max =
if max = 0 || Scanning.eof ib then max else
- match Scanning.checked_peek_char ib with
+ match Scanning.cautious_peek_char ib with
| '0' .. '9' as c ->
let max = Scanning.store_char ib c max in
loop true max
@@ -329,11 +340,12 @@ let scan_decimal_digits max ib =
| c -> max in
loop false max;;
-(* Other cases uses a predicate argument to scan_digits. *)
+(* To scan numbers from other bases, we use a predicate argument to
+ scan_digits. *)
let scan_digits digitp max ib =
let rec loop inside max =
if max = 0 || Scanning.eof ib then max else
- match Scanning.checked_peek_char ib with
+ match Scanning.cautious_peek_char ib with
| c when digitp c ->
let max = Scanning.store_char ib c max in
loop true max
@@ -343,28 +355,41 @@ let scan_digits digitp max ib =
| _ -> max in
loop false max;;
-let scan_binary_digits =
- let is_binary_digit = function
+let scan_digits_plus digitp max ib =
+ let c = Scanning.checked_peek_char ib in
+ if digitp c then
+ let max = Scanning.store_char ib c max in
+ scan_digits digitp max ib
+ else bad_input_char c;;
+
+let is_binary_digit = function
| '0' .. '1' -> true
- | _ -> false in
- scan_digits is_binary_digit;;
+ | _ -> false;;
-let scan_octal_digits =
- let is_octal_digit = function
+let scan_binary_digits = scan_digits is_binary_digit;;
+let scan_binary_int = scan_digits_plus is_binary_digit;;
+
+let is_octal_digit = function
| '0' .. '7' -> true
- | _ -> false in
- scan_digits is_octal_digit;;
+ | _ -> false;;
+
+let scan_octal_digits = scan_digits is_octal_digit;;
+let scan_octal_int = scan_digits_plus is_octal_digit;;
-let scan_hexadecimal_digits =
- let is_hexa_digit = function
+let is_hexa_digit = function
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
- | _ -> false in
- scan_digits is_hexa_digit;;
+ | _ -> false;;
+
+let scan_hexadecimal_digits = scan_digits is_hexa_digit;;
+let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;;
-(* Decimal integers. *)
+(* Scan a decimal integer. *)
let scan_unsigned_decimal_int max ib =
- if max = 0 || Scanning.eof ib then bad_input "decimal digit" else
- scan_decimal_digits max ib;;
+ match Scanning.checked_peek_char ib with
+ | '0' .. '9' as c ->
+ let max = Scanning.store_char ib c max in
+ scan_decimal_digits max ib
+ | c -> bad_input_char c;;
let scan_sign max ib =
let c = Scanning.checked_peek_char ib in
@@ -392,28 +417,27 @@ let scan_unsigned_int max ib =
| 'o' -> scan_octal_digits (Scanning.store_char ib c max) ib
| 'b' -> scan_binary_digits (Scanning.store_char ib c max) ib
| c -> scan_decimal_digits max ib end
- | c -> scan_decimal_digits max ib;;
+ | c -> scan_unsigned_decimal_int max ib;;
let scan_optionally_signed_int max ib =
let max = scan_sign max ib in
- if max = 0 || Scanning.eof ib then bad_input "bad int" else
scan_unsigned_int max ib;;
-let scan_int conv max ib =
+let scan_int_conv conv max ib =
match conv with
- | 'b' -> scan_binary_digits max ib
+ | 'b' -> scan_binary_int max ib
| 'd' -> scan_optionally_signed_decimal_int max ib
| 'i' -> scan_optionally_signed_int max ib
- | 'o' -> scan_octal_digits max ib
+ | 'o' -> scan_octal_int max ib
| 'u' -> scan_unsigned_decimal_int max ib
- | 'x' | 'X' -> scan_hexadecimal_digits max ib
+ | 'x' | 'X' -> scan_hexadecimal_int max ib
| c -> assert false;;
(* Scanning floating point numbers. *)
(* Fractional part is optional and can be reduced to 0 digits. *)
let scan_frac_part max ib =
if max = 0 || Scanning.eof ib then max else
- scan_unsigned_decimal_int max ib;;
+ scan_decimal_digits max ib;;
(* Exp part is optional and can be reduced to 0 digits. *)
let scan_exp_part max ib =
@@ -424,8 +448,17 @@ let scan_exp_part max ib =
scan_optionally_signed_decimal_int (Scanning.store_char ib c max) ib
| _ -> max;;
+(* An optional sign followed by a possibly empty sequence of decimal digits. *)
+let scan_optionally_signed_decimal_digits max ib =
+ let max = scan_sign max ib in
+ scan_decimal_digits max ib;;
+
+(* Scan the integer part of a floating point number, (not using the
+ Caml lexical convention since the integer part can be empty). *)
+let scan_int_part = scan_optionally_signed_decimal_digits;;
+
let scan_float max ib =
- let max = scan_optionally_signed_decimal_int max ib in
+ let max = scan_int_part max ib in
if max = 0 || Scanning.eof ib then max else
let c = Scanning.peek_char ib in
match c with
@@ -448,7 +481,7 @@ let scan_Float max ib =
scan_exp_part max ib
| c -> bad_float ();;
-(* Scan a regular string: it stops with a space or one of the
+(* Scan a regular string: stops when encountering a space or one of the
characters in stp. It also stops when the maximum number of
characters has been read.*)
let scan_string stp max ib =
@@ -630,7 +663,7 @@ let make_bv bit set =
if i <= lim then
match set.[i] with
| '-' when rp ->
- (* if i = 0 then rp is false (since the initial call is loop false 0)
+ (* if i = 0 then rp is false (since the initial call is loop bit false 0)
hence i >= 1 and the following is safe. *)
let c1 = set.[i - 1] in
let i = i + 1 in
@@ -665,6 +698,7 @@ let make_setp stp char_set =
(fun c -> if c == p1 || c == p2 then 1 else 0)
| 3 ->
let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
+ if p2 = '-' then make_pred 1 set stp else
(fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0)
| n -> make_pred 1 set stp
end
@@ -679,6 +713,7 @@ let make_setp stp char_set =
(fun c -> if c != p1 && c != p2 then 1 else 0)
| 3 ->
let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
+ if p2 = '-' then make_pred 0 set stp else
(fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0)
| n -> make_pred 0 set stp
end;;
@@ -751,14 +786,14 @@ let scan_chars_in_char_set stp char_set max ib =
| 0 -> loop (fun c -> 0) max
| 1 -> loop_pos1 set.[0] max
| 2 -> loop_pos2 set.[0] set.[1] max
- | 3 -> loop_pos3 set.[0] set.[1] set.[2] max
+ | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] max
| n -> loop (find_setp stp char_set) max end
| Neg_set set ->
begin match String.length set with
| 0 -> loop (fun c -> 1) max
| 1 -> loop_neg1 set.[0] max
| 2 -> loop_neg2 set.[0] set.[1] max
- | 3 -> loop_neg3 set.[0] set.[1] set.[2] max
+ | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max
| n -> loop (find_setp stp char_set) max end in
if stp != [] then check_char_in stp ib;
max;;
@@ -834,7 +869,7 @@ let kscanf ib ef fmt f =
if conv = 'c' then scan_char max ib else scan_Char max ib in
scan_fmt (stack f (token_char ib)) (i + 1)
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
- let x = scan_int conv max ib in
+ let x = scan_int_conv conv max ib in
scan_fmt (stack f (token_int conv ib)) (i + 1)
| 'f' | 'g' | 'G' | 'e' | 'E' ->
let x = scan_float max ib in
@@ -862,7 +897,7 @@ let kscanf ib ef fmt f =
if i > lim then scan_fmt (stack f (get_count t ib)) i else begin
match fmt.[i] with
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
- let x = scan_int conv max ib in
+ let x = scan_int_conv conv max ib in
begin match t with
| 'l' -> scan_fmt (stack f (token_int32 conv ib)) (i + 1)
| 'L' -> scan_fmt (stack f (token_int64 conv ib)) (i + 1)
diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli
index 891bf1abf3..09753cdbc4 100644
--- a/stdlib/scanf.mli
+++ b/stdlib/scanf.mli
@@ -197,7 +197,6 @@ val bscanf :
*)
val fscanf : in_channel -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;;
-
(** Same as {!Scanf.bscanf}, but inputs from the given channel.
Warning: since all scanning functions operate from a scanning
@@ -221,7 +220,7 @@ val sscanf : string -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;;
val scanf : ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;;
(** Same as {!Scanf.bscanf}, but reads from the predefined scanning
- buffer [Scanning.stdib] that is connected to [stdin]. *)
+ buffer {!Scanf.Scanning.stdib} that is connected to [stdin]. *)
val kscanf :
Scanning.scanbuf -> (Scanning.scanbuf -> exn -> 'a) ->
diff --git a/stdlib/set.ml b/stdlib/set.ml
index 2404c53854..e4ef7a0d94 100644
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -48,6 +48,7 @@ module type S =
val min_elt: t -> elt
val max_elt: t -> elt
val choose: t -> elt
+ val split: elt -> t -> t * bool * t
end
module Make(Ord: OrderedType) =
@@ -243,23 +244,26 @@ module Make(Ord: OrderedType) =
| (l2, true, r2) ->
concat (diff l1 l2) (diff r1 r2)
- let rec compare_aux l1 l2 =
- match (l1, l2) with
- ([], []) -> 0
- | ([], _) -> -1
- | (_, []) -> 1
- | (Empty :: t1, Empty :: t2) ->
- compare_aux t1 t2
- | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
+ type enumeration = End | More of elt * t * enumeration
+
+ let rec cons_enum s e =
+ match s with
+ Empty -> e
+ | Node(l, v, r, _) -> cons_enum l (More(v, r, e))
+
+ let rec compare_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> 0
+ | (End, _) -> -1
+ | (_, End) -> 1
+ | (More(v1, r1, e1), More(v2, r2, e2)) ->
let c = Ord.compare v1 v2 in
- if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
- | (Node(l1, v1, r1, _) :: t1, t2) ->
- compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
- | (t1, Node(l2, v2, r2, _) :: t2) ->
- compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
+ if c <> 0
+ then c
+ else compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
let compare s1 s2 =
- compare_aux [s1] [s2]
+ compare_aux (cons_enum s1 End) (cons_enum s2 End)
let equal s1 s2 =
compare s1 s2 = 0
diff --git a/stdlib/set.mli b/stdlib/set.mli
index fc4a1f4be6..69b0895f1e 100644
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -136,6 +136,15 @@ module type S =
(** Return one element of the given set, or raise [Not_found] if
the set is empty. Which element is chosen is unspecified,
but equal elements will be chosen for equal sets. *)
+
+ val split: elt -> t -> t * bool * t
+ (** [split x s] returns a triple [(l, present, r)], where
+ [l] is the set of elements of [s] that are
+ strictly less than [x];
+ [r] is the set of elements of [s] that are
+ strictly greater than [x];
+ [present] is [false] if [s] contains no element equal to [x],
+ or [true] if [s] contains an element equal to [x]. *)
end
(** Output signature of the functor {!Set.Make}. *)
diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli
index 4750bbffbc..fbda4b7a49 100644
--- a/stdlib/stdLabels.mli
+++ b/stdlib/stdLabels.mli
@@ -50,6 +50,7 @@ module Array :
val fold_right : f:('a -> 'b -> 'b) -> 'a array -> init:'b -> 'b
val sort : cmp:('a -> 'a -> int) -> 'a array -> unit
val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+ val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
end
@@ -97,6 +98,7 @@ module List :
val combine : 'a list -> 'b list -> ('a * 'b) list
val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+ val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
end
module String :
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index 99ecb18528..d1478525c6 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -78,4 +78,4 @@ let catch_break on =
(* OCaml version string, must be in the format described in sys.mli. *)
-let ocaml_version = "3.07+14 (2004-02-03)";;
+let ocaml_version = "3.07+22 (2004-06-16)";;
diff --git a/stdlib/sys.mli b/stdlib/sys.mli
index 28cb6de0e3..9c829b1660 100644
--- a/stdlib/sys.mli
+++ b/stdlib/sys.mli
@@ -32,7 +32,9 @@ external remove : string -> unit = "caml_sys_remove"
external rename : string -> string -> unit = "caml_sys_rename"
(** Rename a file. The first argument is the old name and the
- second is the new name. *)
+ second is the new name. If there is already another file
+ under the new name, [rename] may replace it, or raise an
+ exception, depending on your operating system. *)
external getenv : string -> string = "caml_sys_getenv"
(** Return the value associated to a variable in the process
@@ -98,9 +100,11 @@ type signal_behavior =
external signal :
int -> signal_behavior -> signal_behavior = "caml_install_signal_handler"
-(** Set the behavior of the system on receipt of a given signal.
- The first argument is the signal number. Return the behavior
- previously associated with the signal. *)
+(** Set the behavior of the system on receipt of a given signal. The
+ first argument is the signal number. Return the behavior
+ previously associated with the signal. If the signal number is
+ invalid (or not available on your system), an [Invalid_argument]
+ exception is raised. *)
val set_signal : int -> signal_behavior -> unit
(** Same as {!Sys.signal} but return value is ignored. *)
View Lorry Controller Status