summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/aux_file.ml92
-rw-r--r--lib/aux_file.mli22
-rw-r--r--lib/backtrace.ml116
-rw-r--r--lib/backtrace.mli96
-rw-r--r--lib/bigint.ml160
-rw-r--r--lib/bigint.mli4
-rw-r--r--lib/cArray.ml528
-rw-r--r--lib/cArray.mli132
-rw-r--r--lib/cList.ml785
-rw-r--r--lib/cList.mli229
-rw-r--r--lib/cMap.ml168
-rw-r--r--lib/cMap.mli67
-rw-r--r--lib/cObj.ml203
-rw-r--r--lib/cObj.mli59
-rw-r--r--lib/cSet.ml67
-rw-r--r--lib/cSet.mli31
-rw-r--r--lib/cSig.mli47
-rw-r--r--lib/cStack.ml42
-rw-r--r--lib/cStack.mli56
-rw-r--r--lib/cString.ml174
-rw-r--r--lib/cString.mli78
-rw-r--r--lib/cThread.ml76
-rw-r--r--lib/cThread.mli26
-rw-r--r--lib/cUnix.ml139
-rw-r--r--lib/cUnix.mli66
-rw-r--r--lib/canary.ml (renamed from lib/gmapl.ml)37
-rw-r--r--lib/canary.mli (renamed from lib/gmapl.mli)26
-rw-r--r--lib/clib.mllib39
-rw-r--r--lib/compat.ml4242
-rw-r--r--lib/control.ml91
-rw-r--r--lib/control.mli26
-rw-r--r--lib/deque.ml97
-rw-r--r--lib/deque.mli58
-rw-r--r--lib/dnet.ml293
-rw-r--r--lib/dnet.mli126
-rw-r--r--lib/dyn.ml48
-rw-r--r--lib/dyn.mli4
-rw-r--r--lib/envars.ml267
-rw-r--r--lib/envars.mli71
-rw-r--r--lib/ephemeron.ml89
-rw-r--r--lib/ephemeron.mli52
-rw-r--r--lib/errors.ml71
-rw-r--r--lib/errors.mli54
-rw-r--r--lib/exninfo.ml104
-rw-r--r--lib/exninfo.mli39
-rw-r--r--lib/explore.ml8
-rw-r--r--lib/explore.mli2
-rw-r--r--lib/feedback.ml171
-rw-r--r--lib/feedback.mli68
-rw-r--r--lib/flags.ml155
-rw-r--r--lib/flags.mli78
-rw-r--r--lib/fmap.ml133
-rw-r--r--lib/fmap.mli23
-rw-r--r--lib/fset.ml235
-rw-r--r--lib/fset.mli25
-rw-r--r--lib/future.ml220
-rw-r--r--lib/future.mli162
-rw-r--r--lib/genarg.ml235
-rw-r--r--lib/genarg.mli278
-rw-r--r--lib/gmap.ml140
-rw-r--r--lib/gmap.mli28
-rw-r--r--lib/hMap.ml332
-rw-r--r--lib/hMap.mli28
-rw-r--r--lib/hashcons.ml141
-rw-r--r--lib/hashcons.mli80
-rw-r--r--lib/hashset.ml203
-rw-r--r--lib/hashset.mli47
-rw-r--r--lib/hashtbl_alt.ml109
-rw-r--r--lib/hashtbl_alt.mli41
-rw-r--r--lib/heap.ml147
-rw-r--r--lib/heap.mli2
-rw-r--r--lib/hook.ml32
-rw-r--r--lib/hook.mli27
-rw-r--r--lib/iStream.ml90
-rw-r--r--lib/iStream.mli81
-rw-r--r--lib/int.ml237
-rw-r--r--lib/int.mli79
-rw-r--r--lib/lib.mllib31
-rw-r--r--lib/loc.ml79
-rw-r--r--lib/loc.mli66
-rw-r--r--lib/monad.ml157
-rw-r--r--lib/monad.mli90
-rw-r--r--lib/option.ml50
-rw-r--r--lib/option.mli39
-rw-r--r--lib/pp.ml591
-rw-r--r--lib/pp.ml4351
-rw-r--r--lib/pp.mli233
-rw-r--r--lib/pp_control.ml3
-rw-r--r--lib/pp_control.mli2
-rw-r--r--lib/predicate.ml6
-rw-r--r--lib/profile.ml131
-rw-r--r--lib/profile.mli15
-rw-r--r--lib/remoteCounter.ml48
-rw-r--r--lib/remoteCounter.mli29
-rw-r--r--lib/richpp.ml177
-rw-r--r--lib/richpp.mli41
-rw-r--r--lib/rtree.ml189
-rw-r--r--lib/rtree.mli44
-rw-r--r--lib/serialize.ml116
-rw-r--r--lib/serialize.mli37
-rw-r--r--lib/spawn.ml258
-rw-r--r--lib/spawn.mli81
-rw-r--r--lib/stateid.ml50
-rw-r--r--lib/stateid.mli45
-rw-r--r--lib/store.ml120
-rw-r--r--lib/store.mli43
-rw-r--r--lib/system.ml378
-rw-r--r--lib/system.mli64
-rw-r--r--lib/terminal.ml284
-rw-r--r--lib/terminal.mli61
-rw-r--r--lib/trie.ml89
-rw-r--r--lib/trie.mli61
-rw-r--r--lib/tries.ml78
-rw-r--r--lib/tries.mli34
-rw-r--r--lib/unicode.ml241
-rw-r--r--lib/unicode.mli28
-rw-r--r--lib/unionfind.ml27
-rw-r--r--lib/unionfind.mli29
-rw-r--r--lib/util.ml1498
-rw-r--r--lib/util.mli371
-rw-r--r--lib/xml_datatype.mli19
-rw-r--r--lib/xml_lexer.mli4
-rw-r--r--lib/xml_lexer.mll419
-rw-r--r--lib/xml_parser.ml299
-rw-r--r--lib/xml_parser.mli33
-rw-r--r--lib/xml_printer.ml143
-rw-r--r--lib/xml_printer.mli29
-rw-r--r--lib/xml_utils.ml223
-rw-r--r--lib/xml_utils.mli93
129 files changed, 11135 insertions, 5426 deletions
diff --git a/lib/aux_file.ml b/lib/aux_file.ml
new file mode 100644
index 00000000..c9018c9e
--- /dev/null
+++ b/lib/aux_file.ml
@@ -0,0 +1,92 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* The file format is a header
+ * ("COQAUX%d %s %s\n" version hex_hash path)
+ * followed by an arbitrary number of entries
+ * ("%d %d %s %S\n" loc_begin loc_end key value) *)
+
+open Filename
+
+let version = 1
+
+let oc = ref None
+
+let aux_file_name_for vfile =
+ dirname vfile ^ "/." ^ chop_extension(basename vfile) ^ ".aux"
+
+let mk_absolute vfile =
+ let vfile = CUnix.remove_path_dot vfile in
+ if Filename.is_relative vfile then CUnix.correct_path vfile (Sys.getcwd ())
+ else vfile
+
+let start_aux_file_for vfile =
+ let vfile = mk_absolute vfile in
+ oc := Some (open_out (aux_file_name_for vfile));
+ Printf.fprintf (Option.get !oc) "COQAUX%d %s %s\n"
+ version (Digest.to_hex (Digest.file vfile)) vfile
+
+let stop_aux_file () =
+ close_out (Option.get !oc);
+ oc := None
+
+let recording () = not (Option.is_empty !oc)
+
+module H = Map.Make(struct type t = int * int let compare = compare end)
+module M = Map.Make(String)
+type data = string M.t
+type aux_file = data H.t
+
+let empty_aux_file = H.empty
+
+let get aux loc key = M.find key (H.find (Loc.unloc loc) aux)
+
+let record_in_aux_at loc key v =
+ Option.iter (fun oc ->
+ let i, j = Loc.unloc loc in
+ Printf.fprintf oc "%d %d %s %S\n" i j key v)
+ !oc
+
+let current_loc = ref Loc.ghost
+
+let record_in_aux_set_at loc = current_loc := loc
+
+let record_in_aux key v = record_in_aux_at !current_loc key v
+
+let set h loc k v =
+ let m = try H.find loc h with Not_found -> M.empty in
+ H.add loc (M.add k v m) h
+
+let load_aux_file_for vfile =
+ let vfile = mk_absolute vfile in
+ let ret3 x y z = x, y, z in
+ let ret4 x y z t = x, y, z, t in
+ let h = ref empty_aux_file in
+ let add loc k v = h := set !h loc k v in
+ let aux_fname = aux_file_name_for vfile in
+ try
+ let ic = open_in aux_fname in
+ let ver, hash, fname = Scanf.fscanf ic "COQAUX%d %s %s\n" ret3 in
+ if ver <> version then raise (Failure "aux file version mismatch");
+ if fname <> vfile then
+ raise (Failure "aux file name mismatch");
+ let only_dummyloc = Digest.to_hex (Digest.file vfile) <> hash in
+ while true do
+ let i, j, k, v = Scanf.fscanf ic "%d %d %s %S\n" ret4 in
+ if not only_dummyloc || (i = 0 && j = 0) then add (i,j) k v;
+ done;
+ raise End_of_file
+ with
+ | End_of_file -> !h
+ | Sys_error s | Scanf.Scan_failure s
+ | Failure s | Invalid_argument s ->
+ Flags.if_verbose
+ Pp.msg_warning Pp.(str"Loading file "++str aux_fname++str": "++str s);
+ empty_aux_file
+
+let set h loc k v = set h (Loc.unloc loc) k v
diff --git a/lib/aux_file.mli b/lib/aux_file.mli
new file mode 100644
index 00000000..e340fc65
--- /dev/null
+++ b/lib/aux_file.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type aux_file
+
+val load_aux_file_for : string -> aux_file
+val get : aux_file -> Loc.t -> string -> string
+val empty_aux_file : aux_file
+val set : aux_file -> Loc.t -> string -> string -> aux_file
+
+val start_aux_file_for : string -> unit
+val stop_aux_file : unit -> unit
+val recording : unit -> bool
+
+val record_in_aux_at : Loc.t -> string -> string -> unit
+val record_in_aux : string -> string -> unit
+val record_in_aux_set_at : Loc.t -> unit
diff --git a/lib/backtrace.ml b/lib/backtrace.ml
new file mode 100644
index 00000000..b3b8bdea
--- /dev/null
+++ b/lib/backtrace.ml
@@ -0,0 +1,116 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+type raw_frame =
+| Known_location of bool (* is_raise *)
+ * string (* filename *)
+ * int (* line number *)
+ * int (* start char *)
+ * int (* end char *)
+| Unknown_location of bool (*is_raise*)
+
+type location = {
+ loc_filename : string;
+ loc_line : int;
+ loc_start : int;
+ loc_end : int;
+}
+
+type frame = { frame_location : location option; frame_raised : bool; }
+
+external get_exception_backtrace: unit -> raw_frame array option
+ = "caml_get_exception_backtrace"
+
+type t = raw_frame array list
+(** List of partial raw stack frames, in reverse order *)
+
+let empty = []
+
+let of_raw = function
+| Unknown_location r ->
+ { frame_location = None; frame_raised = r; }
+| Known_location (r, file, line, st, en) ->
+ let loc = {
+ loc_filename = file;
+ loc_line = line;
+ loc_start = st;
+ loc_end = en;
+ } in
+ { frame_location = Some loc; frame_raised = r; }
+
+let rec repr_aux accu = function
+| [] -> accu
+| fragment :: stack ->
+ let len = Array.length fragment in
+ let rec append accu i =
+ if i = len then accu
+ else append (of_raw fragment.(i) :: accu) (succ i)
+ in
+ repr_aux (append accu 0) stack
+
+let repr bt = repr_aux [] (List.rev bt)
+
+let push stack = match get_exception_backtrace () with
+| None -> []
+| Some frames -> frames :: stack
+
+(** Utilities *)
+
+let print_frame frame =
+ let raise = if frame.frame_raised then "raise" else "frame" in
+ match frame.frame_location with
+ | None -> Printf.sprintf "%s @ unknown" raise
+ | Some loc ->
+ Printf.sprintf "%s @ file \"%s\", line %d, characters %d-%d"
+ raise loc.loc_filename loc.loc_line loc.loc_start loc.loc_end
+
+(** Exception manipulation *)
+
+let backtrace : t Exninfo.t = Exninfo.make ()
+
+let is_recording = ref false
+
+let record_backtrace b =
+ let () = Printexc.record_backtrace b in
+ is_recording := b
+
+let get_backtrace e =
+ Exninfo.get e backtrace
+
+let add_backtrace e =
+ if !is_recording then
+ (** This must be the first function call, otherwise the stack may be
+ destroyed *)
+ let current = get_exception_backtrace () in
+ let info = Exninfo.info e in
+ begin match current with
+ | None -> (e, info)
+ | Some fragment ->
+ let bt = match get_backtrace info with
+ | None -> []
+ | Some bt -> bt
+ in
+ let bt = fragment :: bt in
+ (e, Exninfo.add info backtrace bt)
+ end
+ else
+ let info = Exninfo.info e in
+ (e, info)
+
+let app_backtrace ~src ~dst =
+ if !is_recording then
+ match get_backtrace src with
+ | None -> dst
+ | Some bt ->
+ match get_backtrace dst with
+ | None ->
+ Exninfo.add dst backtrace bt
+ | Some nbt ->
+ let bt = bt @ nbt in
+ Exninfo.add dst backtrace bt
+ else dst
diff --git a/lib/backtrace.mli b/lib/backtrace.mli
new file mode 100644
index 00000000..dd82165b
--- /dev/null
+++ b/lib/backtrace.mli
@@ -0,0 +1,96 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** * Low-level management of OCaml backtraces.
+
+ Currently, OCaml manages its backtraces in a very imperative way. That is to
+ say, it only keeps track of the stack destroyed by the last raised exception.
+ So we have to be very careful when using this module not to do silly things.
+
+ Basically, you need to manually handle the reraising of exceptions. In order
+ to do so, each time the backtrace is lost, you must [push] the stack fragment.
+ This essentially occurs whenever a [with] handler is crossed.
+
+*)
+
+(** {5 Backtrace information} *)
+
+type location = {
+ loc_filename : string;
+ loc_line : int;
+ loc_start : int;
+ loc_end : int;
+}
+(** OCaml debugging information for function calls. *)
+
+type frame = { frame_location : location option; frame_raised : bool; }
+(** A frame contains two informations: its optional physical location, and
+ whether it raised the exception or let it pass through. *)
+
+type t
+(** Type of backtraces. They're essentially stack of frames. *)
+
+val empty : t
+(** Empty frame stack. *)
+
+val push : t -> t
+(** Add the current backtrace information to a given backtrace. *)
+
+val repr : t -> frame list
+(** Represent a backtrace as a list of frames. Leftmost element is the outermost
+ call. *)
+
+(** {5 Utilities} *)
+
+val print_frame : frame -> string
+(** Represent a frame. *)
+
+(** {5 Exception handling} *)
+
+val record_backtrace : bool -> unit
+(** Whether to activate the backtrace recording mechanism. Note that it will
+ only work whenever the program was compiled with the [debug] flag. *)
+
+val get_backtrace : Exninfo.info -> t option
+(** Retrieve the optional backtrace coming with the exception. *)
+
+val add_backtrace : exn -> Exninfo.iexn
+(** Add the current backtrace information to the given exception.
+
+ The intended use case is of the form: {[
+
+ try foo
+ with
+ | Bar -> bar
+ | err -> let err = add_backtrace err in baz
+
+ ]}
+
+ WARNING: any intermediate code between the [with] and the handler may
+ modify the backtrace. Yes, that includes [when] clauses. Ideally, what you
+ should do is something like: {[
+
+ try foo
+ with err ->
+ let err = add_backtrace err in
+ match err with
+ | Bar -> bar
+ | err -> baz
+
+ ]}
+
+ I admit that's a bit heavy, but there is not much to do...
+
+*)
+
+val app_backtrace : src:Exninfo.info -> dst:Exninfo.info -> Exninfo.info
+(** Append the backtrace from [src] to [dst]. The returned exception is [dst]
+ except for its backtrace information. This is targeted at container
+ exceptions, that is, exceptions that contain exceptions. This way, one can
+ transfer the backtrace from the container to the underlying exception, as if
+ the latter was the one originally raised. *)
diff --git a/lib/bigint.ml b/lib/bigint.ml
index 42a71f83..e739c7a1 100644
--- a/lib/bigint.ml
+++ b/lib/bigint.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -43,11 +43,11 @@ let size =
let format_size =
(* How to parametrize a printf format *)
- if size = 4 then Printf.sprintf "%04d"
- else if size = 9 then Printf.sprintf "%09d"
+ if Int.equal size 4 then Printf.sprintf "%04d"
+ else if Int.equal size 9 then Printf.sprintf "%09d"
else fun n ->
let rec aux j l n =
- if j=size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10)
+ if Int.equal j size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10)
in String.concat "" (aux 0 [] n)
(* The base is 10^size *)
@@ -63,27 +63,31 @@ module ArrayInt = struct
(* Basic numbers *)
let zero = [||]
-let neg_one = [|-1|]
+
+let is_zero = function
+| [||] -> true
+| _ -> false
(* An array is canonical when
- it is empty
- it is [|-1|]
- its first bloc is in [-base;-1[U]0;base[
and the other blocs are in [0;base[. *)
-
+(*
let canonical n =
let ok x = (0 <= x && x < base) in
- let rec ok_tail k = (k = 0) || (ok n.(k) && ok_tail (k-1)) in
- let ok_init x = (-base <= x && x < base && x <> -1 && x <> 0)
+ let rec ok_tail k = (Int.equal k 0) || (ok n.(k) && ok_tail (k-1)) in
+ let ok_init x = (-base <= x && x < base && not (Int.equal x (-1)) && not (Int.equal x 0))
in
- (n = [||]) || (n = [|-1|]) ||
+ (is_zero n) || (match n with [|-1|] -> true | _ -> false) ||
(ok_init n.(0) && ok_tail (Array.length n - 1))
+*)
(* [normalize_pos] : removing initial blocks of 0 *)
let normalize_pos n =
let k = ref 0 in
- while !k < Array.length n & n.(!k) = 0 do incr k done;
+ while !k < Array.length n && Int.equal n.(!k) 0 do incr k done;
Array.sub n !k (Array.length n - !k)
(* [normalize_neg] : avoid (-1) as first bloc.
@@ -92,32 +96,32 @@ let normalize_pos n =
let normalize_neg n =
let k = ref 1 in
- while !k < Array.length n & n.(!k) = base - 1 do incr k done;
+ while !k < Array.length n && Int.equal n.(!k) (base - 1) do incr k done;
let n' = Array.sub n !k (Array.length n - !k) in
- if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
+ if Int.equal (Array.length n') 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
(* [normalize] : avoid 0 and (-1) as first bloc.
input: an array with first bloc in [-base;base[ and others in [0;base[
output: a canonical array *)
-let rec normalize n =
- if Array.length n = 0 then n
- else if n.(0) = -1 then normalize_neg n
- else if n.(0) = 0 then normalize_pos n
+let normalize n =
+ if Int.equal (Array.length n) 0 then n
+ else if Int.equal n.(0) (-1) then normalize_neg n
+ else if Int.equal n.(0) 0 then normalize_pos n
else n
(* Opposite (expects and returns canonical arrays) *)
let neg m =
- if m = zero then zero else
+ if is_zero m then zero else
let n = Array.copy m in
let i = ref (Array.length m - 1) in
- while !i > 0 & n.(!i) = 0 do decr i done;
- if !i = 0 then begin
+ while !i > 0 && Int.equal n.(!i) 0 do decr i done;
+ if Int.equal !i 0 then begin
n.(0) <- - n.(0);
(* n.(0) cannot be 0 since m is canonical *)
- if n.(0) = -1 then normalize_neg n
- else if n.(0) = base then (n.(0) <- 0; Array.append [| 1 |] n)
+ if Int.equal n.(0) (-1) then normalize_neg n
+ else if Int.equal n.(0) base then (n.(0) <- 0; Array.append [| 1 |] n)
else n
end else begin
(* here n.(!i) <> 0, hence 0 < base - n.(!i) < base for n canonical *)
@@ -132,10 +136,10 @@ let neg m =
let push_carry r j =
let j = ref j in
- while !j > 0 & r.(!j) < 0 do
+ while !j > 0 && r.(!j) < 0 do
r.(!j) <- r.(!j) + base; decr j; r.(!j) <- r.(!j) - 1
done;
- while !j > 0 & r.(!j) >= base do
+ while !j > 0 && r.(!j) >= base do
r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1
done;
(* here r.(0) could be in [-2*base;2*base-1] *)
@@ -144,7 +148,7 @@ let push_carry r j =
else normalize r (* in case r.(0) is 0 or -1 *)
let add_to r a j =
- if a = zero then r else begin
+ if is_zero a then r else begin
for i = Array.length r - 1 downto j+1 do
r.(i) <- r.(i) + a.(i-j);
if r.(i) >= base then (r.(i) <- r.(i) - base; r.(i-1) <- r.(i-1) + 1)
@@ -158,7 +162,7 @@ let add n m =
if d > 0 then add_to (Array.copy n) m d else add_to (Array.copy m) n (-d)
let sub_to r a j =
- if a = zero then r else begin
+ if is_zero a then r else begin
for i = Array.length r - 1 downto j+1 do
r.(i) <- r.(i) - a.(i-j);
if r.(i) < 0 then (r.(i) <- r.(i) + base; r.(i-1) <- r.(i-1) - 1)
@@ -172,10 +176,10 @@ let sub n m =
if d >= 0 then sub_to (Array.copy n) m d
else let r = neg m in add_to r n (Array.length r - Array.length n)
-let rec mult m n =
- if m = zero or n = zero then zero else
+let mult m n =
+ if is_zero m || is_zero n then zero else
let l = Array.length m + Array.length n in
- let r = Array.create l 0 in
+ let r = Array.make l 0 in
for i = Array.length m - 1 downto 0 do
for j = Array.length n - 1 downto 0 do
let p = m.(i) * n.(j) + r.(i+j+1) in
@@ -184,49 +188,62 @@ let rec mult m n =
then (p + 1) / base - 1, (p + 1) mod base + base - 1
else p / base, p mod base in
r.(i+j+1) <- s;
- if q <> 0 then r.(i+j) <- r.(i+j) + q;
+ if not (Int.equal q 0) then r.(i+j) <- r.(i+j) + q;
done
done;
normalize r
(* Comparisons *)
-let is_strictly_neg n = n<>[||] && n.(0) < 0
-let is_strictly_pos n = n<>[||] && n.(0) > 0
-let is_neg_or_zero n = n=[||] or n.(0) < 0
-let is_pos_or_zero n = n=[||] or n.(0) > 0
+let is_strictly_neg n = not (is_zero n) && n.(0) < 0
+let is_strictly_pos n = not (is_zero n) && n.(0) > 0
+let is_neg_or_zero n = is_zero n || n.(0) < 0
+let is_pos_or_zero n = is_zero n || n.(0) > 0
+
+(* Is m without its i first blocs less then n without its j first blocs ?
+ Invariant : |m|-i = |n|-j *)
let rec less_than_same_size m n i j =
i < Array.length m &&
- (m.(i) < n.(j) or (m.(i) = n.(j) && less_than_same_size m n (i+1) (j+1)))
+ (m.(i) < n.(j) || (Int.equal m.(i) n.(j) && less_than_same_size m n (i+1) (j+1)))
let less_than m n =
if is_strictly_neg m then
- is_pos_or_zero n or Array.length m > Array.length n
- or (Array.length m = Array.length n && less_than_same_size m n 0 0)
+ is_pos_or_zero n || Array.length m > Array.length n
+ || (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0)
else
- is_strictly_pos n && (Array.length m < Array.length n or
- (Array.length m = Array.length n && less_than_same_size m n 0 0))
+ is_strictly_pos n && (Array.length m < Array.length n ||
+ (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0))
(* For this equality test it is critical that n and m are canonical *)
-let equal m n = (m = n)
+let rec array_eq len v1 v2 i =
+ if Int.equal len i then true
+ else
+ Int.equal v1.(i) v2.(i) && array_eq len v1 v2 (succ i)
+
+let equal m n =
+ let lenm = Array.length m in
+ let lenn = Array.length n in
+ (Int.equal lenm lenn) && (array_eq lenm m n 0)
+
+(* Is m without its k top blocs less than n ? *)
let less_than_shift_pos k m n =
(Array.length m - k < Array.length n)
- or (Array.length m - k = Array.length n && less_than_same_size m n k 0)
+ || (Int.equal (Array.length m - k) (Array.length n) && less_than_same_size m n k 0)
let rec can_divide k m d i =
- (i = Array.length d) or
- (m.(k+i) > d.(i)) or
- (m.(k+i) = d.(i) && can_divide k m d (i+1))
+ (Int.equal i (Array.length d)) ||
+ (m.(k+i) > d.(i)) ||
+ (Int.equal m.(k+i) d.(i) && can_divide k m d (i+1))
(* For two big nums m and d and a small number q,
computes m - d * q * base^(|m|-|d|-k) in-place (in m).
Both m d and q are positive. *)
let sub_mult m d q k =
- if q <> 0 then
+ if not (Int.equal q 0) then
for i = Array.length d - 1 downto 0 do
let v = d.(i) * q in
m.(k+i) <- m.(k+i) - v mod base;
@@ -249,17 +266,17 @@ let euclid m d =
let isnegm, m =
if is_strictly_neg m then (-1),neg m else 1,Array.copy m in
let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in
- if d = zero then raise Division_by_zero;
+ if is_zero d then raise Division_by_zero;
let q,r =
if less_than m d then (zero,m) else
let ql = Array.length m - Array.length d in
- let q = Array.create (ql+1) 0 in
+ let q = Array.make (ql+1) 0 in
let i = ref 0 in
while not (less_than_shift_pos !i m d) do
- if m.(!i)=0 then incr i else
+ if Int.equal m.(!i) 0 then incr i else
if can_divide !i m d 0 then begin
let v =
- if Array.length d > 1 && d.(0) <> m.(!i) then
+ if Array.length d > 1 && not (Int.equal d.(0) m.(!i)) then
(m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1)
else
m.(!i) / d.(0) in
@@ -276,30 +293,30 @@ let euclid m d =
end
done;
(normalize q, normalize m) in
- (if isnegd * isnegm = -1 then neg q else q),
- (if isnegm = -1 then neg r else r)
+ (if Int.equal (isnegd * isnegm) (-1) then neg q else q),
+ (if Int.equal isnegm (-1) then neg r else r)
(* Parsing/printing ordinary 10-based numbers *)
let of_string s =
let len = String.length s in
- let isneg = len > 1 & s.[0] = '-' in
+ let isneg = len > 1 && s.[0] == '-' in
let d = ref (if isneg then 1 else 0) in
- while !d < len && s.[!d] = '0' do incr d done;
- if !d = len then zero else
+ while !d < len && s.[!d] == '0' do incr d done;
+ if Int.equal !d len then zero else
let r = (len - !d) mod size in
let h = String.sub s (!d) r in
- let e = if h<>"" then 1 else 0 in
+ let e = match h with "" -> 0 | _ -> 1 in
let l = (len - !d) / size in
- let a = Array.create (l + e) 0 in
- if e=1 then a.(0) <- int_of_string h;
- for i=1 to l do
+ let a = Array.make (l + e) 0 in
+ if Int.equal e 1 then a.(0) <- int_of_string h;
+ for i = 1 to l do
a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size)
done;
if isneg then neg a else a
let to_string_pos sgn n =
- if Array.length n = 0 then "0" else
+ if Int.equal (Array.length n) 0 then "0" else
sgn ^
String.concat ""
(string_of_int n.(0) :: List.map format_size (List.tl (Array.to_list n)))
@@ -337,7 +354,7 @@ let mkarray n =
t
let ints_of_int n =
- if n = 0 then [| |]
+ if Int.equal n 0 then [| |]
else if small n then [| n |]
else mkarray n
@@ -346,8 +363,8 @@ let of_int n =
let of_ints n =
let n = normalize n in (* TODO: using normalize here seems redundant now *)
- if n = zero then Obj.repr 0 else
- if Array.length n = 1 then Obj.repr n.(0) else
+ if is_zero n then Obj.repr 0 else
+ if Int.equal (Array.length n) 1 then Obj.repr n.(0) else
Obj.repr n
let coerce_to_int = (Obj.magic : Obj.t -> int)
@@ -361,7 +378,7 @@ let int_of_ints =
let maxi = mkarray max_int and mini = mkarray min_int in
fun t ->
let l = Array.length t in
- if (l > 3) || (l = 3 && (less_than maxi t || less_than t mini))
+ if (l > 3) || (Int.equal l 3 && (less_than maxi t || less_than t mini))
then failwith "Bigint.to_int: too large";
let sum = ref 0 in
let pow = ref 1 in
@@ -379,28 +396,28 @@ let app_pair f (m, n) =
(f m, f n)
let add m n =
- if Obj.is_int m & Obj.is_int n
+ if Obj.is_int m && Obj.is_int n
then of_int (coerce_to_int m + coerce_to_int n)
else of_ints (add (to_ints m) (to_ints n))
let sub m n =
- if Obj.is_int m & Obj.is_int n
+ if Obj.is_int m && Obj.is_int n
then of_int (coerce_to_int m - coerce_to_int n)
else of_ints (sub (to_ints m) (to_ints n))
let mult m n =
- if Obj.is_int m & Obj.is_int n
+ if Obj.is_int m && Obj.is_int n
then of_int (coerce_to_int m * coerce_to_int n)
else of_ints (mult (to_ints m) (to_ints n))
let euclid m n =
- if Obj.is_int m & Obj.is_int n
+ if Obj.is_int m && Obj.is_int n
then app_pair of_int
(coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n)
else app_pair of_ints (euclid (to_ints m) (to_ints n))
let less_than m n =
- if Obj.is_int m & Obj.is_int n
+ if Obj.is_int m && Obj.is_int n
then coerce_to_int m < coerce_to_int n
else less_than (to_ints m) (to_ints n)
@@ -420,14 +437,17 @@ let mult_2 n = add n n
let div2_with_rest n =
let (q,b) = euclid n two in
- (q, b = one)
+ (q, b == one)
let is_strictly_neg n = is_strictly_neg (to_ints n)
let is_strictly_pos n = is_strictly_pos (to_ints n)
let is_neg_or_zero n = is_neg_or_zero (to_ints n)
let is_pos_or_zero n = is_pos_or_zero (to_ints n)
-let equal m n = (m = n)
+let equal m n =
+ if Obj.is_block m && Obj.is_block n then
+ ArrayInt.equal (Obj.obj m) (Obj.obj n)
+ else m == n
(* spiwack: computes n^m *)
(* The basic idea of the algorithm is that n^(2m) = (n^2)^m *)
@@ -441,7 +461,7 @@ let pow =
odd_rest
else
let quo = m lsr 1 (* i.e. m/2 *)
- and odd = (m land 1) <> 0 in
+ and odd = not (Int.equal (m land 1) 0) in
pow_aux
(if odd then mult n odd_rest else odd_rest)
(mult n n)
diff --git a/lib/bigint.mli b/lib/bigint.mli
index dd2cdea6..02e3c1ad 100644
--- a/lib/bigint.mli
+++ b/lib/bigint.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -11,6 +11,8 @@
type bigint
val of_string : string -> bigint
+(** May raise a Failure just as [int_of_string] on non-numerical strings *)
+
val to_string : bigint -> string
val of_int : int -> bigint
diff --git a/lib/cArray.ml b/lib/cArray.ml
new file mode 100644
index 00000000..16034543
--- /dev/null
+++ b/lib/cArray.ml
@@ -0,0 +1,528 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+module type S = module type of Array
+
+module type ExtS =
+sig
+ include S
+ val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
+ val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
+ val is_empty : 'a array -> bool
+ val exists : ('a -> bool) -> 'a array -> bool
+ val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+ val for_all : ('a -> bool) -> 'a array -> bool
+ val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+ val for_all3 : ('a -> 'b -> 'c -> bool) ->
+ 'a array -> 'b array -> 'c array -> bool
+ val for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
+ 'a array -> 'b array -> 'c array -> 'd array -> bool
+ val for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
+ val findi : (int -> 'a -> bool) -> 'a array -> int option
+ val hd : 'a array -> 'a
+ val tl : 'a array -> 'a array
+ val last : 'a array -> 'a
+ val cons : 'a -> 'a array -> 'a array
+ val rev : 'a array -> unit
+ val fold_right_i :
+ (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+ val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+ val fold_right2 :
+ ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
+ val fold_left2 :
+ ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+ val fold_left3 :
+ ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
+ val fold_left2_i :
+ (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+ val fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+ val map_to_list : ('a -> 'b) -> 'a array -> 'b list
+ val map_of_list : ('a -> 'b) -> 'a list -> 'b array
+ val chop : int -> 'a array -> 'a array * 'a array
+ val smartmap : ('a -> 'a) -> 'a array -> 'a array
+ val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array
+ val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+ val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+ val map3 :
+ ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
+ val map_left : ('a -> 'b) -> 'a array -> 'b array
+ val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+ val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
+ val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
+ val fold_map2' :
+ ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
+ val distinct : 'a array -> bool
+ val rev_of_list : 'a list -> 'a array
+ val rev_to_list : 'a array -> 'a list
+ val filter_with : bool list -> 'a array -> 'a array
+end
+
+include Array
+
+let uget = Array.unsafe_get
+
+(* Arrays *)
+
+let compare cmp v1 v2 =
+ if v1 == v2 then 0
+ else
+ let len = Array.length v1 in
+ let c = Int.compare len (Array.length v2) in
+ if c <> 0 then c else
+ let rec loop i =
+ if i < 0 then 0
+ else
+ let x = uget v1 i in
+ let y = uget v2 i in
+ let c = cmp x y in
+ if c <> 0 then c
+ else loop (i - 1)
+ in
+ loop (len - 1)
+
+let equal cmp t1 t2 =
+ if t1 == t2 then true else
+ let len = Array.length t1 in
+ if not (Int.equal len (Array.length t2)) then false
+ else
+ let rec aux i =
+ if i < 0 then true
+ else
+ let x = uget t1 i in
+ let y = uget t2 i in
+ cmp x y && aux (pred i)
+ in
+ aux (len - 1)
+
+let is_empty array = Int.equal (Array.length array) 0
+
+let exists f v =
+ let rec exrec = function
+ | -1 -> false
+ | n -> f (uget v n) || (exrec (n-1))
+ in
+ exrec ((Array.length v)-1)
+
+let exists2 f v1 v2 =
+ let rec exrec = function
+ | -1 -> false
+ | n -> f (uget v1 n) (uget v2 n) || (exrec (n-1))
+ in
+ let lv1 = Array.length v1 in
+ lv1 = Array.length v2 && exrec (lv1-1)
+
+let for_all f v =
+ let rec allrec = function
+ | -1 -> true
+ | n ->
+ let ans = f (uget v n) in
+ ans && (allrec (n-1))
+ in
+ allrec ((Array.length v)-1)
+
+let for_all2 f v1 v2 =
+ let rec allrec = function
+ | -1 -> true
+ | n ->
+ let ans = f (uget v1 n) (uget v2 n) in
+ ans && (allrec (n-1))
+ in
+ let lv1 = Array.length v1 in
+ lv1 = Array.length v2 && allrec (pred lv1)
+
+let for_all3 f v1 v2 v3 =
+ let rec allrec = function
+ | -1 -> true
+ | n ->
+ let ans = f (uget v1 n)
+ (uget v2 n) (uget v3 n)
+ in
+ ans && (allrec (n-1))
+ in
+ let lv1 = Array.length v1 in
+ lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1)
+
+let for_all4 f v1 v2 v3 v4 =
+ let rec allrec = function
+ | -1 -> true
+ | n ->
+ let ans = f (uget v1 n)
+ (uget v2 n) (uget v3 n) (uget v4 n)
+ in
+ ans && (allrec (n-1))
+ in
+ let lv1 = Array.length v1 in
+ lv1 = Array.length v2 &&
+ lv1 = Array.length v3 &&
+ lv1 = Array.length v4 &&
+ allrec (pred lv1)
+
+let for_all_i f i v =
+ let len = Array.length v in
+ let rec allrec i n =
+ n = len || f i (uget v n) && allrec (i+1) (n+1) in
+ allrec i 0
+
+exception Found of int
+
+let findi (pred: int -> 'a -> bool) (arr: 'a array) : int option =
+ try
+ for i=0 to Array.length arr - 1 do
+ if pred i (uget arr i) then raise (Found i) done;
+ None
+ with Found i -> Some i
+
+let hd v =
+ match Array.length v with
+ | 0 -> failwith "Array.hd"
+ | _ -> uget v 0
+
+let tl v =
+ match Array.length v with
+ | 0 -> failwith "Array.tl"
+ | n -> Array.sub v 1 (pred n)
+
+let last v =
+ match Array.length v with
+ | 0 -> failwith "Array.last"
+ | n -> uget v (pred n)
+
+let cons e v =
+ let len = Array.length v in
+ let ans = Array.make (Array.length v + 1) e in
+ let () = Array.blit v 0 ans 1 len in
+ ans
+
+let rev t =
+ let n=Array.length t in
+ if n <=0 then ()
+ else
+ for i = 0 to pred (n/2) do
+ let tmp = uget t ((pred n)-i) in
+ Array.unsafe_set t ((pred n)-i) (uget t i);
+ Array.unsafe_set t i tmp
+ done
+
+let fold_right_i f v a =
+ let rec fold a n =
+ if n=0 then a
+ else
+ let k = n-1 in
+ fold (f k (uget v k) a) k in
+ fold a (Array.length v)
+
+let fold_left_i f v a =
+ let n = Array.length a in
+ let rec fold i v = if i = n then v else fold (succ i) (f i v (uget a i)) in
+ fold 0 v
+
+let fold_right2 f v1 v2 a =
+ let lv1 = Array.length v1 in
+ let rec fold a n =
+ if n=0 then a
+ else
+ let k = n-1 in
+ fold (f (uget v1 k) (uget v2 k) a) k in
+ if Array.length v2 <> lv1 then invalid_arg "Array.fold_right2";
+ fold a lv1
+
+let fold_left2 f a v1 v2 =
+ let lv1 = Array.length v1 in
+ let rec fold a n =
+ if n >= lv1 then a else fold (f a (uget v1 n) (uget v2 n)) (succ n)
+ in
+ if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2";
+ fold a 0
+
+let fold_left2_i f a v1 v2 =
+ let lv1 = Array.length v1 in
+ let rec fold a n =
+ if n >= lv1 then a else fold (f n a (uget v1 n) (uget v2 n)) (succ n)
+ in
+ if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2";
+ fold a 0
+
+let fold_left3 f a v1 v2 v3 =
+ let lv1 = Array.length v1 in
+ let rec fold a n =
+ if n >= lv1 then a
+ else fold (f a (uget v1 n) (uget v2 n) (uget v3 n)) (succ n)
+ in
+ if Array.length v2 <> lv1 || Array.length v3 <> lv1 then
+ invalid_arg "Array.fold_left2";
+ fold a 0
+
+let fold_left_from n f a v =
+ let len = Array.length v in
+ let () = if n < 0 then invalid_arg "Array.fold_left_from" in
+ let rec fold a n =
+ if n >= len then a else fold (f a (uget v n)) (succ n)
+ in
+ fold a n
+
+let rev_of_list = function
+| [] -> [| |]
+| x :: l ->
+ let len = List.length l in
+ let ans = Array.make (succ len) x in
+ let rec set i = function
+ | [] -> ()
+ | x :: l ->
+ Array.unsafe_set ans i x;
+ set (pred i) l
+ in
+ let () = set (len - 1) l in
+ ans
+
+let map_to_list f v =
+ List.map f (Array.to_list v)
+
+let map_of_list f l =
+ let len = List.length l in
+ let rec fill i v = function
+ | [] -> ()
+ | x :: l ->
+ Array.unsafe_set v i (f x);
+ fill (succ i) v l
+ in
+ match l with
+ | [] -> [||]
+ | x :: l ->
+ let ans = Array.make len (f x) in
+ let () = fill 1 ans l in
+ ans
+
+let chop n v =
+ let vlen = Array.length v in
+ if n > vlen then failwith "Array.chop";
+ (Array.sub v 0 n, Array.sub v n (vlen-n))
+
+(* If none of the elements is changed by f we return ar itself.
+ The while loop looks for the first such an element.
+ If found, we break here and the new array is produced,
+ but f is not re-applied to elements that are already checked *)
+let smartmap f (ar : 'a array) =
+ let len = Array.length ar in
+ let i = ref 0 in
+ let break = ref true in
+ let temp = ref None in
+ while !break && (!i < len) do
+ let v = Array.unsafe_get ar !i in
+ let v' = f v in
+ if v == v' then incr i
+ else begin
+ break := false;
+ temp := Some v';
+ end
+ done;
+ if !i < len then begin
+ (** The array is not the same as the original one *)
+ let ans : 'a array = Array.copy ar in
+ let v = match !temp with None -> assert false | Some x -> x in
+ Array.unsafe_set ans !i v;
+ incr i;
+ while !i < len do
+ let v = Array.unsafe_get ar !i in
+ let v' = f v in
+ if v != v' then Array.unsafe_set ans !i v';
+ incr i
+ done;
+ ans
+ end else ar
+
+(** Same as [smartmap] but threads a state meanwhile *)
+let smartfoldmap f accu (ar : 'a array) =
+ let len = Array.length ar in
+ let i = ref 0 in
+ let break = ref true in
+ let r = ref accu in
+ (** This variable is never accessed unset *)
+ let temp = ref None in
+ while !break && (!i < len) do
+ let v = Array.unsafe_get ar !i in
+ let (accu, v') = f !r v in
+ r := accu;
+ if v == v' then incr i
+ else begin
+ break := false;
+ temp := Some v';
+ end
+ done;
+ if !i < len then begin
+ let ans : 'a array = Array.copy ar in
+ let v = match !temp with None -> assert false | Some x -> x in
+ Array.unsafe_set ans !i v;
+ incr i;
+ while !i < len do
+ let v = Array.unsafe_get ar !i in
+ let (accu, v') = f !r v in
+ r := accu;
+ if v != v' then Array.unsafe_set ans !i v';
+ incr i
+ done;
+ !r, ans
+ end else !r, ar
+
+let map2 f v1 v2 =
+ let len1 = Array.length v1 in
+ let len2 = Array.length v2 in
+ let () = if not (Int.equal len1 len2) then invalid_arg "Array.map2" in
+ if Int.equal len1 0 then
+ [| |]
+ else begin
+ let res = Array.make len1 (f (uget v1 0) (uget v2 0)) in
+ for i = 1 to pred len1 do
+ Array.unsafe_set res i (f (uget v1 i) (uget v2 i))
+ done;
+ res
+ end
+
+let map2_i f v1 v2 =
+ let len1 = Array.length v1 in
+ let len2 = Array.length v2 in
+ let () = if not (Int.equal len1 len2) then invalid_arg "Array.map2" in
+ if Int.equal len1 0 then
+ [| |]
+ else begin
+ let res = Array.make len1 (f 0 (uget v1 0) (uget v2 0)) in
+ for i = 1 to pred len1 do
+ Array.unsafe_set res i (f i (uget v1 i) (uget v2 i))
+ done;
+ res
+ end
+
+let map3 f v1 v2 v3 =
+ let len1 = Array.length v1 in
+ let () =
+ if len1 <> Array.length v2 || len1 <> Array.length v3
+ then invalid_arg "Array.map3"
+ in
+ if Int.equal len1 0 then
+ [| |]
+ else begin
+ let res = Array.make len1 (f (uget v1 0) (uget v2 0) (uget v3 0)) in
+ for i = 1 to pred len1 do
+ Array.unsafe_set res i (f (uget v1 i) (uget v2 i) (uget v3 i))
+ done;
+ res
+ end
+
+let map_left f a = (* Ocaml does not guarantee Array.map is LR *)
+ let l = Array.length a in (* (even if so), then we rewrite it *)
+ if Int.equal l 0 then [||] else begin
+ let r = Array.make l (f (uget a 0)) in
+ for i = 1 to l - 1 do
+ Array.unsafe_set r i (f (uget a i))
+ done;
+ r
+ end
+
+let iter2 f v1 v2 =
+ let len1 = Array.length v1 in
+ let len2 = Array.length v2 in
+ let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in
+ for i = 0 to len1 - 1 do f (uget v1 i) (uget v2 i) done
+
+let pure_functional = false
+
+let fold_map' f v e =
+if pure_functional then
+ let (l,e) =
+ Array.fold_right
+ (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
+ v ([],e) in
+ (Array.of_list l,e)
+else
+ let e' = ref e in
+ let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in
+ (v',!e')
+
+let fold_map f e v =
+ let e' = ref e in
+ let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in
+ (!e',v')
+
+let fold_map2' f v1 v2 e =
+ let e' = ref e in
+ let v' =
+ map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2
+ in
+ (v',!e')
+
+
+let distinct v =
+ let visited = Hashtbl.create 23 in
+ try
+ Array.iter
+ (fun x ->
+ if Hashtbl.mem visited x then raise Exit
+ else Hashtbl.add visited x x)
+ v;
+ true
+ with Exit -> false
+
+let rev_to_list a =
+ let rec tolist i res =
+ if i >= Array.length a then res else tolist (i+1) (uget a i :: res) in
+ tolist 0 []
+
+let filter_with filter v =
+ Array.of_list (CList.filter_with filter (Array.to_list v))
+
+module Fun1 =
+struct
+
+ let map f arg v = match v with
+ | [| |] -> [| |]
+ | _ ->
+ let len = Array.length v in
+ let x0 = Array.unsafe_get v 0 in
+ let ans = Array.make len (f arg x0) in
+ for i = 1 to pred len do
+ let x = Array.unsafe_get v i in
+ Array.unsafe_set ans i (f arg x)
+ done;
+ ans
+
+ let smartmap f arg (ar : 'a array) =
+ let len = Array.length ar in
+ let i = ref 0 in
+ let break = ref true in
+ let temp = ref None in
+ while !break && (!i < len) do
+ let v = Array.unsafe_get ar !i in
+ let v' = f arg v in
+ if v == v' then incr i
+ else begin
+ break := false;
+ temp := Some v';
+ end
+ done;
+ if !i < len then begin
+ (** The array is not the same as the original one *)
+ let ans : 'a array = Array.copy ar in
+ let v = match !temp with None -> assert false | Some x -> x in
+ Array.unsafe_set ans !i v;
+ incr i;
+ while !i < len do
+ let v = Array.unsafe_get ar !i in
+ let v' = f arg v in
+ if v != v' then Array.unsafe_set ans !i v';
+ incr i
+ done;
+ ans
+ end else ar
+
+ let iter f arg v =
+ let len = Array.length v in
+ for i = 0 to pred len do
+ let x = uget v i in
+ f arg x
+ done
+
+end
diff --git a/lib/cArray.mli b/lib/cArray.mli
new file mode 100644
index 00000000..39c35e2d
--- /dev/null
+++ b/lib/cArray.mli
@@ -0,0 +1,132 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+module type S = module type of Array
+
+module type ExtS =
+sig
+ include S
+ val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
+ (** First size comparison, then lexicographic order. *)
+
+ val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
+ (** Lift equality to array type. *)
+
+ val is_empty : 'a array -> bool
+ (** True whenever the array is empty. *)
+
+ val exists : ('a -> bool) -> 'a array -> bool
+ (** As [List.exists] but on arrays. *)
+
+ val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+
+ val for_all : ('a -> bool) -> 'a array -> bool
+ val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+ val for_all3 : ('a -> 'b -> 'c -> bool) ->
+ 'a array -> 'b array -> 'c array -> bool
+ val for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
+ 'a array -> 'b array -> 'c array -> 'd array -> bool
+ val for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
+
+ val findi : (int -> 'a -> bool) -> 'a array -> int option
+
+ val hd : 'a array -> 'a
+ (** First element of an array, or [Failure "Array.hd"] if empty. *)
+
+ val tl : 'a array -> 'a array
+ (** Remaining part of [hd], or [Failure "Array.tl"] if empty. *)
+
+ val last : 'a array -> 'a
+ (** Last element of an array, or [Failure "Array.last"] if empty. *)
+
+ val cons : 'a -> 'a array -> 'a array
+ (** Append an element on the left. *)
+
+ val rev : 'a array -> unit
+ (** In place reversal. *)
+
+ val fold_right_i :
+ (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+ val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+ val fold_right2 :
+ ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
+ val fold_left2 :
+ ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+ val fold_left3 :
+ ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
+ val fold_left2_i :
+ (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+ val fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+
+ val map_to_list : ('a -> 'b) -> 'a array -> 'b list
+ (** Composition of [map] and [to_list]. *)
+
+ val map_of_list : ('a -> 'b) -> 'a list -> 'b array
+ (** Composition of [map] and [of_list]. *)
+
+ val chop : int -> 'a array -> 'a array * 'a array
+ (** [chop i a] returns [(a1, a2)] s.t. [a = a1 + a2] and [length a1 = n].
+ Raise [Failure "Array.chop"] if [i] is not a valid index. *)
+
+ val smartmap : ('a -> 'a) -> 'a array -> 'a array
+ (** [smartmap f a] behaves as [map f a] but returns [a] instead of a copy when
+ [f x == x] for all [x] in [a]. *)
+
+ val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array
+ (** Same as [smartmap] but threads an additional state left-to-right. *)
+
+ val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+ val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+ val map3 :
+ ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
+
+ val map_left : ('a -> 'b) -> 'a array -> 'b array
+ (** As [map] but guaranteed to be left-to-right. *)
+
+ val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+ (** Iter on two arrays. Raise [Invalid_argument "Array.iter2"] if sizes differ. *)
+
+ val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
+ val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
+ val fold_map2' :
+ ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
+
+ val distinct : 'a array -> bool
+ (** Return [true] if every element of the array is unique (for default
+ equality). *)
+
+ val rev_of_list : 'a list -> 'a array
+ (** [rev_of_list l] is equivalent to [Array.of_list (List.rev l)]. *)
+
+ val rev_to_list : 'a array -> 'a list
+ (** [rev_to_list a] is equivalent to [List.rev (List.of_array a)]. *)
+
+ val filter_with : bool list -> 'a array -> 'a array
+ (** [filter_with b a] selects elements of [a] whose corresponding element in
+ [b] is [true]. Raise [Invalid_argument _] when sizes differ. *)
+
+end
+
+include ExtS
+
+module Fun1 :
+sig
+ val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array
+ (** [Fun1.map f x v = map (f x) v] *)
+
+ val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array
+ (** [Fun1.smartmap f x v = smartmap (f x) v] *)
+
+ val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit
+ (** [Fun1.iter f x v = iter (f x) v] *)
+
+end
+(** The functions defined in this module are the same as the main ones, except
+ that they are all higher-order, and their function arguments have an
+ additional parameter. This allows us to prevent closure creation in critical
+ cases. *)
diff --git a/lib/cList.ml b/lib/cList.ml
new file mode 100644
index 00000000..0ac372d8
--- /dev/null
+++ b/lib/cList.ml
@@ -0,0 +1,785 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+type 'a cmp = 'a -> 'a -> int
+type 'a eq = 'a -> 'a -> bool
+
+module type S = module type of List
+
+module type ExtS =
+sig
+ include S
+ val compare : 'a cmp -> 'a list cmp
+ val equal : 'a eq -> 'a list eq
+ val is_empty : 'a list -> bool
+ val init : int -> (int -> 'a) -> 'a list
+ val mem_f : 'a eq -> 'a -> 'a list -> bool
+ val add_set : 'a eq -> 'a -> 'a list -> 'a list
+ val eq_set : 'a eq -> 'a list -> 'a list -> bool
+ val intersect : 'a eq -> 'a list -> 'a list -> 'a list
+ val union : 'a eq -> 'a list -> 'a list -> 'a list
+ val unionq : 'a list -> 'a list -> 'a list
+ val subtract : 'a eq -> 'a list -> 'a list -> 'a list
+ val subtractq : 'a list -> 'a list -> 'a list
+ val interval : int -> int -> int list
+ val make : int -> 'a -> 'a list
+ val assign : 'a list -> int -> 'a -> 'a list
+ val distinct : 'a list -> bool
+ val distinct_f : 'a cmp -> 'a list -> bool
+ val duplicates : 'a eq -> 'a list -> 'a list
+ val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
+ val map_filter : ('a -> 'b option) -> 'a list -> 'b list
+ val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
+ val filter_with : bool list -> 'a list -> 'a list
+ val smartmap : ('a -> 'a) -> 'a list -> 'a list
+ val map_left : ('a -> 'b) -> 'a list -> 'b list
+ val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+ val map2_i :
+ (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
+ val map3 :
+ ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+ val map4 :
+ ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
+ val filteri :
+ (int -> 'a -> bool) -> 'a list -> 'a list
+ val smartfilter : ('a -> bool) -> 'a list -> 'a list
+ val index : 'a eq -> 'a -> 'a list -> int
+ val index0 : 'a eq -> 'a -> 'a list -> int
+ val iteri : (int -> 'a -> unit) -> 'a list -> unit
+ val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c
+ val fold_right_i : (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
+ val fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
+ val fold_right_and_left :
+ ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
+ val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
+ val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
+ val except : 'a eq -> 'a -> 'a list -> 'a list
+ val remove : 'a eq -> 'a -> 'a list -> 'a list
+ val remove_first : ('a -> bool) -> 'a list -> 'a list
+ val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
+ val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+ val sep_last : 'a list -> 'a * 'a list
+ val find_map : ('a -> 'b option) -> 'a list -> 'b
+ val uniquize : 'a list -> 'a list
+ val sort_uniquize : 'a cmp -> 'a list -> 'a list
+ val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+ val subset : 'a list -> 'a list -> bool
+ val chop : int -> 'a list -> 'a list * 'a list
+ exception IndexOutOfRange
+ val goto : int -> 'a list -> 'a list * 'a list
+ val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
+ val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
+ val firstn : int -> 'a list -> 'a list
+ val last : 'a list -> 'a
+ val lastn : int -> 'a list -> 'a list
+ val skipn : int -> 'a list -> 'a list
+ val skipn_at_least : int -> 'a list -> 'a list
+ val addn : int -> 'a -> 'a list -> 'a list
+ val prefix_of : 'a eq -> 'a list -> 'a list -> bool
+ val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list
+ val drop_last : 'a list -> 'a list
+ val map_append : ('a -> 'b list) -> 'a list -> 'b list
+ val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+ val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
+ val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+ val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
+ val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
+ val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b
+ val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list
+ val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool
+ val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+ val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
+ val combinations : 'a list list -> 'a list list
+ val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
+ val cartesians_filter :
+ ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
+ val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list
+
+ module type MonoS = sig
+ type elt
+ val equal : elt list -> elt list -> bool
+ val mem : elt -> elt list -> bool
+ val assoc : elt -> (elt * 'a) list -> 'a
+ val mem_assoc : elt -> (elt * 'a) list -> bool
+ val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+ val mem_assoc_sym : elt -> ('a * elt) list -> bool
+ end
+
+end
+
+include List
+
+(** Tail-rec implementation of usual functions. This is a well-known trick used
+ in, for instance, ExtLib and Batteries. *)
+
+type 'a cell = {
+ head : 'a;
+ mutable tail : 'a list;
+}
+
+external cast : 'a cell -> 'a list = "%identity"
+
+let rec map_loop f p = function
+| [] -> ()
+| x :: l ->
+ let c = { head = f x; tail = [] } in
+ p.tail <- cast c;
+ map_loop f c l
+
+let map f = function
+| [] -> []
+| x :: l ->
+ let c = { head = f x; tail = [] } in
+ map_loop f c l;
+ cast c
+
+let rec map2_loop f p l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+ let c = { head = f x y; tail = [] } in
+ p.tail <- cast c;
+ map2_loop f c l1 l2
+| _ -> invalid_arg "List.map2"
+
+let map2 f l1 l2 = match l1, l2 with
+| [], [] -> []
+| x :: l1, y :: l2 ->
+ let c = { head = f x y; tail = [] } in
+ map2_loop f c l1 l2;
+ cast c
+| _ -> invalid_arg "List.map2"
+
+let rec append_loop p tl = function
+| [] -> p.tail <- tl
+| x :: l ->
+ let c = { head = x; tail = [] } in
+ p.tail <- cast c;
+ append_loop c tl l
+
+let append l1 l2 = match l1 with
+| [] -> l2
+| x :: l ->
+ let c = { head = x; tail = [] } in
+ append_loop c l2 l;
+ cast c
+
+let rec copy p = function
+| [] -> p
+| x :: l ->
+ let c = { head = x; tail = [] } in
+ p.tail <- cast c;
+ copy c l
+
+let rec init_loop len f p i =
+ if Int.equal i len then ()
+ else
+ let c = { head = f i; tail = [] } in
+ p.tail <- cast c;
+ init_loop len f c (succ i)
+
+let init len f =
+ if len < 0 then invalid_arg "List.init"
+ else if Int.equal len 0 then []
+ else
+ let c = { head = f 0; tail = [] } in
+ init_loop len f c 1;
+ cast c
+
+let rec concat_loop p = function
+| [] -> ()
+| x :: l -> concat_loop (copy p x) l
+
+let concat l =
+ let dummy = { head = Obj.magic 0; tail = [] } in
+ concat_loop dummy l;
+ dummy.tail
+
+let flatten = concat
+
+let rec split_loop p q = function
+| [] -> ()
+| (x, y) :: l ->
+ let cl = { head = x; tail = [] } in
+ let cr = { head = y; tail = [] } in
+ p.tail <- cast cl;
+ q.tail <- cast cr;
+ split_loop cl cr l
+
+let split = function
+| [] -> [], []
+| (x, y) :: l ->
+ let cl = { head = x; tail = [] } in
+ let cr = { head = y; tail = [] } in
+ split_loop cl cr l;
+ (cast cl, cast cr)
+
+let rec combine_loop p l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+ let c = { head = (x, y); tail = [] } in
+ p.tail <- cast c;
+ combine_loop c l1 l2
+| _ -> invalid_arg "List.combine"
+
+let combine l1 l2 = match l1, l2 with
+| [], [] -> []
+| x :: l1, y :: l2 ->
+ let c = { head = (x, y); tail = [] } in
+ combine_loop c l1 l2;
+ cast c
+| _ -> invalid_arg "List.combine"
+
+let rec filter_loop f p = function
+| [] -> ()
+| x :: l ->
+ if f x then
+ let c = { head = x; tail = [] } in
+ let () = p.tail <- cast c in
+ filter_loop f c l
+ else
+ filter_loop f p l
+
+let filter f l =
+ let c = { head = Obj.magic 0; tail = [] } in
+ filter_loop f c l;
+ c.tail
+
+(** FIXME: Already present in OCaml 4.00 *)
+
+let rec map_i_loop f i p = function
+| [] -> ()
+| x :: l ->
+ let c = { head = f i x; tail = [] } in
+ p.tail <- cast c;
+ map_i_loop f (succ i) c l
+
+let map_i f i = function
+| [] -> []
+| x :: l ->
+ let c = { head = f i x; tail = [] } in
+ map_i_loop f (succ i) c l;
+ cast c
+
+(** Extensions of OCaml Stdlib *)
+
+let rec compare cmp l1 l2 =
+ if l1 == l2 then 0 else
+ match l1,l2 with
+ [], [] -> 0
+ | _::_, [] -> 1
+ | [], _::_ -> -1
+ | x1::l1, x2::l2 ->
+ (match cmp x1 x2 with
+ | 0 -> compare cmp l1 l2
+ | c -> c)
+
+let rec equal cmp l1 l2 =
+ l1 == l2 ||
+ match l1, l2 with
+ | [], [] -> true
+ | x1 :: l1, x2 :: l2 ->
+ cmp x1 x2 && equal cmp l1 l2
+ | _ -> false
+
+let is_empty = function
+| [] -> true
+| _ -> false
+
+let mem_f cmp x l = List.exists (cmp x) l
+
+let intersect cmp l1 l2 =
+ filter (fun x -> mem_f cmp x l2) l1
+
+let union cmp l1 l2 =
+ let rec urec = function
+ | [] -> l2
+ | a::l -> if mem_f cmp a l2 then urec l else a::urec l
+ in
+ urec l1
+
+let subtract cmp l1 l2 =
+ if is_empty l2 then l1
+ else List.filter (fun x -> not (mem_f cmp x l2)) l1
+
+let unionq l1 l2 = union (==) l1 l2
+let subtractq l1 l2 = subtract (==) l1 l2
+
+let interval n m =
+ let rec interval_n (l,m) =
+ if n > m then l else interval_n (m::l, pred m)
+ in
+ interval_n ([], m)
+
+let addn n v =
+ let rec aux n l =
+ if Int.equal n 0 then l
+ else aux (pred n) (v :: l)
+ in
+ if n < 0 then invalid_arg "List.addn"
+ else aux n
+
+let make n v = addn n v []
+
+let assign l n e =
+ let rec assrec stk l i = match l, i with
+ | ((h::t), 0) -> List.rev_append stk (e :: t)
+ | ((h::t), n) -> assrec (h :: stk) t (pred n)
+ | ([], _) -> failwith "List.assign"
+ in
+ assrec [] l n
+
+let rec smartmap f l = match l with
+ [] -> l
+ | h::tl ->
+ let h' = f h and tl' = smartmap f tl in
+ if h'==h && tl'==tl then l
+ else h'::tl'
+
+let map_left = map
+
+let map2_i f i l1 l2 =
+ let rec map_i i = function
+ | ([], []) -> []
+ | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
+ | (_, _) -> invalid_arg "map2_i"
+ in
+ map_i i (l1,l2)
+
+let map3 f l1 l2 l3 =
+ let rec map = function
+ | ([], [], []) -> []
+ | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
+ | (_, _, _) -> invalid_arg "map3"
+ in
+ map (l1,l2,l3)
+
+let map4 f l1 l2 l3 l4 =
+ let rec map = function
+ | ([], [], [], []) -> []
+ | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4)
+ | (_, _, _, _) -> invalid_arg "map4"
+ in
+ map (l1,l2,l3,l4)
+
+let rec smartfilter f l = match l with
+ [] -> l
+ | h::tl ->
+ let tl' = smartfilter f tl in
+ if f h then
+ if tl' == tl then l
+ else h :: tl'
+ else tl'
+
+let rec index_f f x l n = match l with
+| [] -> raise Not_found
+| y :: l -> if f x y then n else index_f f x l (succ n)
+
+let index f x l = index_f f x l 1
+
+let index0 f x l = index_f f x l 0
+
+let fold_left_until f accu s =
+ let rec aux accu = function
+ | [] -> accu
+ | x :: xs -> match f accu x with CSig.Stop x -> x | CSig.Cont i -> aux i xs in
+ aux accu s
+
+let fold_right_i f i l =
+ let rec it_f i l a = match l with
+ | [] -> a
+ | b::l -> f (i-1) b (it_f (i-1) l a)
+ in
+ it_f (List.length l + i) l
+
+let fold_left_i f =
+ let rec it_list_f i a = function
+ | [] -> a
+ | b::l -> it_list_f (i+1) (f i a b) l
+ in
+ it_list_f
+
+let rec fold_left3 f accu l1 l2 l3 =
+ match (l1, l2, l3) with
+ ([], [], []) -> accu
+ | (a1::l1, a2::l2, a3::l3) -> fold_left3 f (f accu a1 a2 a3) l1 l2 l3
+ | (_, _, _) -> invalid_arg "List.fold_left3"
+
+(* [fold_right_and_left f [a1;...;an] hd =
+ f (f (... (f (f hd
+ an
+ [an-1;...;a1])
+ an-1
+ [an-2;...;a1])
+ ...)
+ a2
+ [a1])
+ a1
+ []] *)
+
+let fold_right_and_left f l hd =
+ let rec aux tl = function
+ | [] -> hd
+ | a::l -> let hd = aux (a::tl) l in f hd a tl
+ in aux [] l
+
+let iteri f l = fold_left_i (fun i _ x -> f i x) 0 () l
+
+let for_all_i p =
+ let rec for_all_p i = function
+ | [] -> true
+ | a::l -> p i a && for_all_p (i+1) l
+ in
+ for_all_p
+
+let except cmp x l = List.filter (fun y -> not (cmp x y)) l
+
+let remove = except (* Alias *)
+
+let rec remove_first p = function
+ | b::l when p b -> l
+ | b::l -> b::remove_first p l
+ | [] -> raise Not_found
+
+let insert p v l =
+ let rec insrec = function
+ | [] -> [v]
+ | h::tl -> if p v h then v::h::tl else h::insrec tl
+ in
+ insrec l
+
+let add_set cmp x l = if mem_f cmp x l then l else x :: l
+
+(** List equality up to permutation (but considering multiple occurrences) *)
+
+let eq_set cmp l1 l2 =
+ let rec aux l1 = function
+ | [] -> is_empty l1
+ | a::l2 -> aux (remove_first (cmp a) l1) l2 in
+ try aux l1 l2 with Not_found -> false
+
+let for_all2eq f l1 l2 =
+ try List.for_all2 f l1 l2 with Invalid_argument _ -> false
+
+let filteri p =
+ let rec filter_i_rec i = function
+ | [] -> []
+ | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
+ in
+ filter_i_rec 0
+
+let rec sep_last = function
+ | [] -> failwith "sep_last"
+ | hd::[] -> (hd,[])
+ | hd::tl -> let (l,tl) = sep_last tl in (l,hd::tl)
+
+let rec find_map f = function
+| [] -> raise Not_found
+| x :: l ->
+ match f x with
+ | None -> find_map f l
+ | Some y -> y
+
+(* FIXME: we should avoid relying on the generic hash function,
+ just as we'd better avoid Pervasives.compare *)
+
+let uniquize l =
+ let visited = Hashtbl.create 23 in
+ let rec aux acc changed = function
+ | h::t -> if Hashtbl.mem visited h then aux acc true t else
+ begin
+ Hashtbl.add visited h h;
+ aux (h::acc) changed t
+ end
+ | [] -> if changed then List.rev acc else l
+ in aux [] false l
+
+(** [sort_uniquize] might be an alternative to the hashtbl-based
+ [uniquize], when the order of the elements is irrelevant *)
+
+let rec uniquize_sorted cmp = function
+ | a::b::l when Int.equal (cmp a b) 0 -> uniquize_sorted cmp (a::l)
+ | a::l -> a::uniquize_sorted cmp l
+ | [] -> []
+
+let sort_uniquize cmp l = uniquize_sorted cmp (List.sort cmp l)
+
+(* FIXME: again, generic hash function *)
+
+let distinct l =
+ let visited = Hashtbl.create 23 in
+ let rec loop = function
+ | h::t ->
+ if Hashtbl.mem visited h then false
+ else
+ begin
+ Hashtbl.add visited h h;
+ loop t
+ end
+ | [] -> true
+ in loop l
+
+let distinct_f cmp l =
+ let rec loop = function
+ | a::b::_ when Int.equal (cmp a b) 0 -> false
+ | a::l -> loop l
+ | [] -> true
+ in loop (List.sort cmp l)
+
+let rec merge_uniq cmp l1 l2 =
+ match l1, l2 with
+ | [], l2 -> l2
+ | l1, [] -> l1
+ | h1 :: t1, h2 :: t2 ->
+ let c = cmp h1 h2 in
+ if Int.equal c 0
+ then h1 :: merge_uniq cmp t1 t2
+ else if c <= 0
+ then h1 :: merge_uniq cmp t1 l2
+ else h2 :: merge_uniq cmp l1 t2
+
+let rec duplicates cmp = function
+ | [] -> []
+ | x::l ->
+ let l' = duplicates cmp l in
+ if mem_f cmp x l then add_set cmp x l' else l'
+
+let rec filter2_loop f p q l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+ if f x y then
+ let c1 = { head = x; tail = [] } in
+ let c2 = { head = y; tail = [] } in
+ let () = p.tail <- cast c1 in
+ let () = q.tail <- cast c2 in
+ filter2_loop f c1 c2 l1 l2
+ else
+ filter2_loop f p q l1 l2
+| _ -> invalid_arg "List.filter2"
+
+let filter2 f l1 l2 =
+ let c1 = { head = Obj.magic 0; tail = [] } in
+ let c2 = { head = Obj.magic 0; tail = [] } in
+ filter2_loop f c1 c2 l1 l2;
+ (c1.tail, c2.tail)
+
+let rec map_filter f = function
+ | [] -> []
+ | x::l ->
+ let l' = map_filter f l in
+ match f x with None -> l' | Some y -> y::l'
+
+let map_filter_i f =
+ let rec aux i = function
+ | [] -> []
+ | x::l ->
+ let l' = aux (succ i) l in
+ match f i x with None -> l' | Some y -> y::l'
+ in aux 0
+
+let rec filter_with filter l = match filter, l with
+| [], [] -> []
+| true :: filter, x :: l -> x :: filter_with filter l
+| false :: filter, _ :: l -> filter_with filter l
+| _ -> invalid_arg "List.filter_with"
+
+(* FIXME: again, generic hash function *)
+
+let subset l1 l2 =
+ let t2 = Hashtbl.create 151 in
+ List.iter (fun x -> Hashtbl.add t2 x ()) l2;
+ let rec look = function
+ | [] -> true
+ | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
+ in
+ look l1
+
+(** [goto i l] splits [l] into two lists [(l1,l2)] such that
+ [(List.rev l1)++l2=l] and [l1] has length [i]. It raises
+ [IndexOutOfRange] when [i] is negative or greater than the
+ length of [l]. *)
+exception IndexOutOfRange
+let goto n l =
+ let rec goto i acc = function
+ | tl when Int.equal i 0 -> (acc, tl)
+ | h::t -> goto (pred i) (h::acc) t
+ | [] -> raise IndexOutOfRange
+ in
+ goto n [] l
+
+(* [chop i l] splits [l] into two lists [(l1,l2)] such that
+ [l1++l2=l] and [l1] has length [i].
+ It raises [Failure] when [i] is negative or greater than the length of [l] *)
+
+let chop n l =
+ try let (h,t) = goto n l in (List.rev h,t)
+ with IndexOutOfRange -> failwith "List.chop"
+ (* spiwack: should raise [IndexOutOfRange] but I'm afraid of missing
+ a try/with when replacing the exception. *)
+
+(* [split_when p l] splits [l] into two lists [(l1,a::l2)] such that
+ [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
+ If there is no such [a], then it returns [(l,[])] instead *)
+let split_when p =
+ let rec split_when_loop x y =
+ match y with
+ | [] -> (List.rev x,[])
+ | (a::l) -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l
+ in
+ split_when_loop []
+
+let rec split3 = function
+ | [] -> ([], [], [])
+ | (x,y,z)::l ->
+ let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz)
+
+let firstn n l =
+ let rec aux acc = function
+ | (0, l) -> List.rev acc
+ | (n, (h::t)) -> aux (h::acc) (pred n, t)
+ | _ -> failwith "firstn"
+ in
+ aux [] (n,l)
+
+let rec last = function
+ | [] -> failwith "List.last"
+ | [x] -> x
+ | _ :: l -> last l
+
+let lastn n l =
+ let len = List.length l in
+ let rec aux m l =
+ if Int.equal m n then l else aux (m - 1) (List.tl l)
+ in
+ if len < n then failwith "lastn" else aux len l
+
+let rec skipn n l = match n,l with
+ | 0, _ -> l
+ | _, [] -> failwith "List.skipn"
+ | n, _::l -> skipn (pred n) l
+
+let skipn_at_least n l =
+ try skipn n l with Failure _ -> []
+
+let prefix_of cmp prefl l =
+ let rec prefrec = function
+ | (h1::t1, h2::t2) -> cmp h1 h2 && prefrec (t1,t2)
+ | ([], _) -> true
+ | _ -> false
+ in
+ prefrec (prefl,l)
+
+(** if [l=p++t] then [drop_prefix p l] is [t] else [l] *)
+
+let drop_prefix cmp p l =
+ let rec drop_prefix_rec = function
+ | (h1::tp, h2::tl) when cmp h1 h2 -> drop_prefix_rec (tp,tl)
+ | ([], tl) -> tl
+ | _ -> l
+ in
+ drop_prefix_rec (p,l)
+
+let map_append f l = List.flatten (List.map f l)
+
+let map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2)
+
+let share_tails l1 l2 =
+ let rec shr_rev acc = function
+ | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
+ | (l1,l2) -> (List.rev l1, List.rev l2, acc)
+ in
+ shr_rev [] (List.rev l1, List.rev l2)
+
+let rec fold_map f e = function
+ | [] -> (e,[])
+ | h::t ->
+ let e',h' = f e h in
+ let e'',t' = fold_map f e' t in
+ e'',h'::t'
+
+(* (* tail-recursive version of the above function *)
+let fold_map f e l =
+ let g (e,b') h =
+ let (e',h') = f e h in
+ (e',h'::b')
+ in
+ let (e',lrev) = List.fold_left g (e,[]) l in
+ (e',List.rev lrev)
+*)
+
+(* The same, based on fold_right, with the effect accumulated on the right *)
+let fold_map' f l e =
+ List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e)
+
+let map_assoc f = List.map (fun (x,a) -> (x,f a))
+
+let rec assoc_f f a = function
+ | (x, e) :: xs -> if f a x then e else assoc_f f a xs
+ | [] -> raise Not_found
+
+let remove_assoc_f f a l =
+ try remove_first (fun (x,_) -> f a x) l with Not_found -> l
+
+let mem_assoc_f f a l = List.exists (fun (x,_) -> f a x) l
+
+(* A generic cartesian product: for any operator (**),
+ [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
+ and so on if there are more elements in the lists. *)
+
+let cartesian op l1 l2 =
+ map_append (fun x -> List.map (op x) l2) l1
+
+(* [cartesians] is an n-ary cartesian product: it iterates
+ [cartesian] over a list of lists. *)
+
+let cartesians op init ll =
+ List.fold_right (cartesian op) ll [init]
+
+(* combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *)
+
+let combinations l = cartesians (fun x l -> x::l) [] l
+
+let rec combine3 x y z =
+ match x, y, z with
+ | [], [], [] -> []
+ | (x :: xs), (y :: ys), (z :: zs) ->
+ (x, y, z) :: combine3 xs ys zs
+ | _, _, _ -> invalid_arg "List.combine3"
+
+(* Keep only those products that do not return None *)
+
+let cartesian_filter op l1 l2 =
+ map_append (fun x -> map_filter (op x) l2) l1
+
+(* Keep only those products that do not return None *)
+
+let cartesians_filter op init ll =
+ List.fold_right (cartesian_filter op) ll [init]
+
+(* Drop the last element of a list *)
+
+let rec drop_last = function
+ | [] -> assert false
+ | hd :: [] -> []
+ | hd :: tl -> hd :: drop_last tl
+
+(* Factorize lists of pairs according to the left argument *)
+let rec factorize_left cmp = function
+ | (a,b)::l ->
+ let al,l' = partition (fun (a',_) -> cmp a a') l in
+ (a,(b::List.map snd al)) :: factorize_left cmp l'
+ | [] -> []
+
+module type MonoS = sig
+ type elt
+ val equal : elt list -> elt list -> bool
+ val mem : elt -> elt list -> bool
+ val assoc : elt -> (elt * 'a) list -> 'a
+ val mem_assoc : elt -> (elt * 'a) list -> bool
+ val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+ val mem_assoc_sym : elt -> ('a * elt) list -> bool
+end
diff --git a/lib/cList.mli b/lib/cList.mli
new file mode 100644
index 00000000..19eeb250
--- /dev/null
+++ b/lib/cList.mli
@@ -0,0 +1,229 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+type 'a cmp = 'a -> 'a -> int
+type 'a eq = 'a -> 'a -> bool
+
+(** Module type [S] is the one from OCaml Stdlib. *)
+module type S = module type of List
+
+module type ExtS =
+sig
+ include S
+
+ val compare : 'a cmp -> 'a list cmp
+ (** Lexicographic order on lists. *)
+
+ val equal : 'a eq -> 'a list eq
+ (** Lifts equality to list type. *)
+
+ val is_empty : 'a list -> bool
+ (** Checks whether a list is empty *)
+
+ val init : int -> (int -> 'a) -> 'a list
+ (** [init n f] constructs the list [f 0; ... ; f (n - 1)]. *)
+
+ val mem_f : 'a eq -> 'a -> 'a list -> bool
+ (* Same as [List.mem], for some specific equality *)
+
+ val add_set : 'a eq -> 'a -> 'a list -> 'a list
+ (** [add_set x l] adds [x] in [l] if it is not already there, or returns [l]
+ otherwise. *)
+
+ val eq_set : 'a eq -> 'a list eq
+ (** Test equality up to permutation (but considering multiple occurrences) *)
+
+ val intersect : 'a eq -> 'a list -> 'a list -> 'a list
+ val union : 'a eq -> 'a list -> 'a list -> 'a list
+ val unionq : 'a list -> 'a list -> 'a list
+ val subtract : 'a eq -> 'a list -> 'a list -> 'a list
+ val subtractq : 'a list -> 'a list -> 'a list
+
+ val interval : int -> int -> int list
+ (** [interval i j] creates the list [[i; i + 1; ...; j]], or [[]] when
+ [j <= i]. *)
+
+ val make : int -> 'a -> 'a list
+ (** [make n x] returns a list made of [n] times [x]. Raise
+ [Invalid_argument "List.make"] if [n] is negative. *)
+
+ val assign : 'a list -> int -> 'a -> 'a list
+ (** [assign l i x] set the [i]-th element of [l] to [x], starting from [0]. *)
+
+ val distinct : 'a list -> bool
+ (** Return [true] if all elements of the list are distinct. *)
+
+ val distinct_f : 'a cmp -> 'a list -> bool
+
+ val duplicates : 'a eq -> 'a list -> 'a list
+ (** Return the list of unique elements which appear at least twice. Elements
+ are kept in the order of their first appearance. *)
+
+ val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
+ val map_filter : ('a -> 'b option) -> 'a list -> 'b list
+ val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
+
+ val filter_with : bool list -> 'a list -> 'a list
+ (** [filter_with b a] selects elements of [a] whose corresponding element in
+ [b] is [true]. Raise [Invalid_argument _] when sizes differ. *)
+
+ val smartmap : ('a -> 'a) -> 'a list -> 'a list
+ (** [smartmap f [a1...an] = List.map f [a1...an]] but if for all i
+ [f ai == ai], then [smartmap f l == l] *)
+
+ val map_left : ('a -> 'b) -> 'a list -> 'b list
+ (** As [map] but ensures the left-to-right order of evaluation. *)
+
+ val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+ (** As [map] but with the index, which starts from [0]. *)
+
+ val map2_i :
+ (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
+ val map3 :
+ ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+ val map4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list ->
+ 'd list -> 'e list
+ val filteri : (int -> 'a -> bool) -> 'a list -> 'a list
+
+ val smartfilter : ('a -> bool) -> 'a list -> 'a list
+ (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i
+ [f ai = true], then [smartfilter f l == l] *)
+
+ val index : 'a eq -> 'a -> 'a list -> int
+ (** [index] returns the 1st index of an element in a list (counting from 1). *)
+
+ val index0 : 'a eq -> 'a -> 'a list -> int
+ (** [index0] behaves as [index] except that it starts counting at 0. *)
+
+ val iteri : (int -> 'a -> unit) -> 'a list -> unit
+ (** As [iter] but with the index argument (starting from 0). *)
+
+ val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c
+ (** acts like [fold_left f acc s] while [f] returns
+ [Cont acc']; it stops returning [c] as soon as [f] returns [Stop c]. *)
+
+ val fold_right_i : (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
+ val fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
+ val fold_right_and_left :
+ ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
+ val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
+ val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
+ val except : 'a eq -> 'a -> 'a list -> 'a list
+ val remove : 'a eq -> 'a -> 'a list -> 'a list
+
+ val remove_first : ('a -> bool) -> 'a list -> 'a list
+ (** Remove the first element satisfying a predicate, or raise [Not_found] *)
+
+ val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
+ (** Insert at the (first) position so that if the list is ordered wrt to the
+ total order given as argument, the order is preserved *)
+
+ val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+ val sep_last : 'a list -> 'a * 'a list
+
+ val find_map : ('a -> 'b option) -> 'a list -> 'b
+ (** Returns the first element that is mapped to [Some _]. Raise [Not_found] if
+ there is none. *)
+
+ val uniquize : 'a list -> 'a list
+ (** Return the list of elements without duplicates.
+ This is the list unchanged if there was none. *)
+
+ val sort_uniquize : 'a cmp -> 'a list -> 'a list
+ (** Return a sorted and de-duplicated version of a list,
+ according to some comparison function. *)
+
+ val merge_uniq : 'a cmp -> 'a list -> 'a list -> 'a list
+ (** Merge two sorted lists and preserves the uniqueness property. *)
+
+ val subset : 'a list -> 'a list -> bool
+
+ val chop : int -> 'a list -> 'a list * 'a list
+ (** [chop i l] splits [l] into two lists [(l1,l2)] such that
+ [l1++l2=l] and [l1] has length [i]. It raises [Failure] when [i]
+ is negative or greater than the length of [l] *)
+
+ exception IndexOutOfRange
+ val goto: int -> 'a list -> 'a list * 'a list
+ (** [goto i l] splits [l] into two lists [(l1,l2)] such that
+ [(List.rev l1)++l2=l] and [l1] has length [i]. It raises
+ [IndexOutOfRange] when [i] is negative or greater than the
+ length of [l]. *)
+
+
+ val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
+ val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
+ val firstn : int -> 'a list -> 'a list
+ val last : 'a list -> 'a
+ val lastn : int -> 'a list -> 'a list
+ val skipn : int -> 'a list -> 'a list
+ val skipn_at_least : int -> 'a list -> 'a list
+
+ val addn : int -> 'a -> 'a list -> 'a list
+ (** [addn n x l] adds [n] times [x] on the left of [l]. *)
+
+ val prefix_of : 'a eq -> 'a list -> 'a list -> bool
+ (** [prefix_of l1 l2] returns [true] if [l1] is a prefix of [l2], [false]
+ otherwise. *)
+
+ val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list
+ (** [drop_prefix p l] returns [t] if [l=p++t] else return [l]. *)
+
+ val drop_last : 'a list -> 'a list
+
+ val map_append : ('a -> 'b list) -> 'a list -> 'b list
+ (** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)]. *)
+
+ val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+ (** As [map_append]. Raises [Invalid_argument _] if the two lists don't have
+ the same length. *)
+
+ val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
+
+ val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+ (** [fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
+ where [(e_i,k_i)=f e_{i-1} l_i] *)
+
+ val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
+ val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
+ val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b
+ val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list
+ val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool
+
+ val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+ (** A generic cartesian product: for any operator (**),
+ [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
+ and so on if there are more elements in the lists. *)
+
+ val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
+ (** [cartesians] is an n-ary cartesian product: it iterates
+ [cartesian] over a list of lists. *)
+
+ val combinations : 'a list list -> 'a list list
+ (** combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
+
+ val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
+
+ val cartesians_filter :
+ ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
+ (** Keep only those products that do not return None *)
+
+ val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list
+
+ module type MonoS = sig
+ type elt
+ val equal : elt list -> elt list -> bool
+ val mem : elt -> elt list -> bool
+ val assoc : elt -> (elt * 'a) list -> 'a
+ val mem_assoc : elt -> (elt * 'a) list -> bool
+ val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+ val mem_assoc_sym : elt -> ('a * elt) list -> bool
+ end
+end
+
+include ExtS
diff --git a/lib/cMap.ml b/lib/cMap.ml
new file mode 100644
index 00000000..cf590d96
--- /dev/null
+++ b/lib/cMap.ml
@@ -0,0 +1,168 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module type OrderedType =
+sig
+ type t
+ val compare : t -> t -> int
+end
+
+module type S = Map.S
+
+module type ExtS =
+sig
+ include Map.S
+ module Set : CSig.SetS with type elt = key
+ val update : key -> 'a -> 'a t -> 'a t
+ val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t
+ val domain : 'a t -> Set.t
+ val bind : (key -> 'a) -> Set.t -> 'a t
+ val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val smartmap : ('a -> 'a) -> 'a t -> 'a t
+ val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t
+ module Unsafe :
+ sig
+ val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
+ end
+end
+
+module MapExt (M : Map.OrderedType) :
+sig
+ type 'a map = 'a Map.Make(M).t
+ val update : M.t -> 'a -> 'a map -> 'a map
+ val modify : M.t -> (M.t -> 'a -> 'a) -> 'a map -> 'a map
+ val domain : 'a map -> Set.Make(M).t
+ val bind : (M.t -> 'a) -> Set.Make(M).t -> 'a map
+ val fold_left : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b
+ val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b
+ val smartmap : ('a -> 'a) -> 'a map -> 'a map
+ val smartmapi : (M.t -> 'a -> 'a) -> 'a map -> 'a map
+ module Unsafe :
+ sig
+ val map : (M.t -> 'a -> M.t * 'b) -> 'a map -> 'b map
+ end
+end =
+struct
+ (** This unsafe module is a way to access to the actual implementations of
+ OCaml sets and maps without reimplementing them ourselves. It is quite
+ dubious that these implementations will ever be changed... Nonetheless,
+ if this happens, we can still implement a less clever version of [domain].
+ *)
+
+ type 'a map = 'a Map.Make(M).t
+ type set = Set.Make(M).t
+
+ type 'a _map =
+ | MEmpty
+ | MNode of 'a map * M.t * 'a * 'a map * int
+
+ type _set =
+ | SEmpty
+ | SNode of set * M.t * set * int
+
+ let map_prj : 'a map -> 'a _map = Obj.magic
+ let map_inj : 'a _map -> 'a map = Obj.magic
+ let set_prj : set -> _set = Obj.magic
+ let set_inj : _set -> set = Obj.magic
+
+ let rec update k v (s : 'a map) : 'a map = match map_prj s with
+ | MEmpty -> raise Not_found
+ | MNode (l, k', v', r, h) ->
+ let c = M.compare k k' in
+ if c < 0 then
+ let l' = update k v l in
+ if l == l' then s
+ else map_inj (MNode (l', k', v', r, h))
+ else if c = 0 then
+ if v' == v then s
+ else map_inj (MNode (l, k', v, r, h))
+ else
+ let r' = update k v r in
+ if r == r' then s
+ else map_inj (MNode (l, k', v', r', h))
+
+ let rec modify k f (s : 'a map) : 'a map = match map_prj s with
+ | MEmpty -> raise Not_found
+ | MNode (l, k', v, r, h) ->
+ let c = M.compare k k' in
+ if c < 0 then
+ let l' = modify k f l in
+ if l == l' then s
+ else map_inj (MNode (l', k', v, r, h))
+ else if c = 0 then
+ let v' = f k' v in
+ if v' == v then s
+ else map_inj (MNode (l, k', v', r, h))
+ else
+ let r' = modify k f r in
+ if r == r' then s
+ else map_inj (MNode (l, k', v, r', h))
+
+ let rec domain (s : 'a map) : set = match map_prj s with
+ | MEmpty -> set_inj SEmpty
+ | MNode (l, k, _, r, h) ->
+ set_inj (SNode (domain l, k, domain r, h))
+ (** This function is essentially identity, but OCaml current stdlib does not
+ take advantage of the similarity of the two structures, so we introduce
+ this unsafe loophole. *)
+
+ let rec bind f (s : set) : 'a map = match set_prj s with
+ | SEmpty -> map_inj MEmpty
+ | SNode (l, k, r, h) ->
+ map_inj (MNode (bind f l, k, f k, bind f r, h))
+ (** Dual operation of [domain]. *)
+
+ let rec fold_left f (s : 'a map) accu = match map_prj s with
+ | MEmpty -> accu
+ | MNode (l, k, v, r, h) ->
+ let accu = f k v (fold_left f l accu) in
+ fold_left f r accu
+
+ let rec fold_right f (s : 'a map) accu = match map_prj s with
+ | MEmpty -> accu
+ | MNode (l, k, v, r, h) ->
+ let accu = f k v (fold_right f r accu) in
+ fold_right f l accu
+
+ let rec smartmap f (s : 'a map) = match map_prj s with
+ | MEmpty -> map_inj MEmpty
+ | MNode (l, k, v, r, h) ->
+ let l' = smartmap f l in
+ let r' = smartmap f r in
+ let v' = f v in
+ if l == l' && r == r' && v == v' then s
+ else map_inj (MNode (l', k, v', r', h))
+
+ let rec smartmapi f (s : 'a map) = match map_prj s with
+ | MEmpty -> map_inj MEmpty
+ | MNode (l, k, v, r, h) ->
+ let l' = smartmapi f l in
+ let r' = smartmapi f r in
+ let v' = f k v in
+ if l == l' && r == r' && v == v' then s
+ else map_inj (MNode (l', k, v', r', h))
+
+ module Unsafe =
+ struct
+
+ let rec map f (s : 'a map) : 'b map = match map_prj s with
+ | MEmpty -> map_inj MEmpty
+ | MNode (l, k, v, r, h) ->
+ let (k, v) = f k v in
+ map_inj (MNode (map f l, k, v, map f r, h))
+
+ end
+
+end
+
+module Make(M : Map.OrderedType) =
+struct
+ include Map.Make(M)
+ include MapExt(M)
+end
diff --git a/lib/cMap.mli b/lib/cMap.mli
new file mode 100644
index 00000000..23d3801e
--- /dev/null
+++ b/lib/cMap.mli
@@ -0,0 +1,67 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** {5 Extended version of OCaml's maps} *)
+
+module type OrderedType =
+sig
+ type t
+ val compare : t -> t -> int
+end
+
+module type S = Map.S
+
+module type ExtS =
+sig
+ include Map.S
+ (** The underlying Map library *)
+
+ module Set : CSig.SetS with type elt = key
+ (** Sets used by the domain function *)
+
+ val update : key -> 'a -> 'a t -> 'a t
+ (** Same as [add], but expects the key to be present, and thus faster.
+ @raise Not_found when the key is unbound in the map. *)
+
+ val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t
+ (** Apply the given function to the binding of the given key.
+ @raise Not_found when the key is unbound in the map. *)
+
+ val domain : 'a t -> Set.t
+ (** Recover the set of keys defined in the map. *)
+
+ val bind : (key -> 'a) -> Set.t -> 'a t
+ (** [bind f s] transform the set [x1; ...; xn] into [x1 := f x1; ...;
+ xn := f xn]. *)
+
+ val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ (** Alias for {!fold}, to easily track where we depend on fold order. *)
+
+ val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ (** Folding keys in decreasing order. *)
+
+ val smartmap : ('a -> 'a) -> 'a t -> 'a t
+ (** As [map] but tries to preserve sharing. *)
+
+ val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t
+ (** As [mapi] but tries to preserve sharing. *)
+
+ module Unsafe :
+ sig
+ val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
+ (** As the usual [map], but also allows modifying the key of a binding.
+ It is required that the mapping function [f] preserves key equality,
+ i.e.: for all (k : key) (x : 'a), compare (fst (f k x)) k = 0. *)
+ end
+
+end
+
+module Make(M : Map.OrderedType) : ExtS with
+ type key = M.t
+ and type 'a t = 'a Map.Make(M).t
+ and module Set := Set.Make(M)
diff --git a/lib/cObj.ml b/lib/cObj.ml
new file mode 100644
index 00000000..7f3ee185
--- /dev/null
+++ b/lib/cObj.ml
@@ -0,0 +1,203 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(*s Logical and physical size of ocaml values. *)
+
+(** {6 Logical sizes} *)
+
+let c = ref 0
+let s = ref 0
+let b = ref 0
+let m = ref 0
+
+let rec obj_stats d t =
+ if Obj.is_int t then m := max d !m
+ else if Obj.tag t >= Obj.no_scan_tag then
+ if Obj.tag t = Obj.string_tag then
+ (c := !c + Obj.size t; b := !b + 1; m := max d !m)
+ else if Obj.tag t = Obj.double_tag then
+ (s := !s + 2; b := !b + 1; m := max d !m)
+ else if Obj.tag t = Obj.double_array_tag then
+ (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m)
+ else (b := !b + 1; m := max d !m)
+ else
+ let n = Obj.size t in
+ s := !s + n; b := !b + 1;
+ block_stats (d + 1) (n - 1) t
+
+and block_stats d i t =
+ if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t)
+
+let obj_stats a =
+ c := 0; s:= 0; b:= 0; m:= 0;
+ obj_stats 0 (Obj.repr a);
+ (!c, !s + !b, !m)
+
+(** {6 Physical sizes} *)
+
+(*s Pointers already visited are stored in a hash-table, where
+ comparisons are done using physical equality. *)
+
+module H = Hashtbl.Make(
+ struct
+ type t = Obj.t
+ let equal = (==)
+ let hash = Hashtbl.hash
+ end)
+
+let node_table = (H.create 257 : unit H.t)
+
+let in_table o = try H.find node_table o; true with Not_found -> false
+
+let add_in_table o = H.add node_table o ()
+
+let reset_table () = H.clear node_table
+
+(*s Objects are traversed recursively, as soon as their tags are less than
+ [no_scan_tag]. [count] records the numbers of words already visited. *)
+
+let size_of_double = Obj.size (Obj.repr 1.0)
+
+let count = ref 0
+
+let rec traverse t =
+ if not (in_table t) && Obj.is_block t then begin
+ add_in_table t;
+ let n = Obj.size t in
+ let tag = Obj.tag t in
+ if tag < Obj.no_scan_tag then
+ begin
+ count := !count + 1 + n;
+ for i = 0 to n - 1 do traverse (Obj.field t i) done
+ end
+ else if tag = Obj.string_tag then
+ count := !count + 1 + n
+ else if tag = Obj.double_tag then
+ count := !count + size_of_double
+ else if tag = Obj.double_array_tag then
+ count := !count + 1 + size_of_double * n
+ else
+ incr count
+ end
+
+(*s Sizes of objects in words and in bytes. The size in bytes is computed
+ system-independently according to [Sys.word_size]. *)
+
+let size o =
+ reset_table ();
+ count := 0;
+ traverse (Obj.repr o);
+ !count
+
+let size_b o = (size o) * (Sys.word_size / 8)
+
+let size_kb o = (size o) / (8192 / Sys.word_size)
+
+(** {6 Physical sizes with sharing} *)
+
+(** This time, all the size of objects are computed with respect
+ to a larger object containing them all, and we only count
+ the new blocks not already seen earlier in the left-to-right
+ visit of the englobing object.
+
+ The very same object could have a zero size or not, depending
+ of the occurrence we're considering in the englobing object.
+ For speaking of occurrences, we use an [int list] for a path
+ of field indexes from the outmost block to the one we're looking.
+ In the list, the leftmost integer is the field index in the deepest
+ block.
+*)
+
+(** We now store in the hashtable the size (with sharing), and
+ also the position of the first occurrence of the object *)
+
+let node_sizes = (H.create 257 : (int*int list) H.t)
+let get_size o = H.find node_sizes o
+let add_size o n pos = H.replace node_sizes o (n,pos)
+let reset_sizes () = H.clear node_sizes
+let global_object = ref (Obj.repr 0)
+
+(** [sum n f] is [f 0 + f 1 + ... + f (n-1)], evaluated from left to right *)
+
+let sum n f =
+ let rec loop k acc = if k >= n then acc else loop (k+1) (acc + f k)
+ in loop 0 0
+
+(** Recursive visit of the main object, filling the hashtable *)
+
+let rec compute_size o pos =
+ if not (Obj.is_block o) then 0
+ else
+ try
+ let _ = get_size o in 0 (* already seen *)
+ with Not_found ->
+ let n = Obj.size o in
+ add_size o (-1) pos (* temp size, for cyclic values *);
+ let tag = Obj.tag o in
+ let size =
+ if tag < Obj.no_scan_tag then
+ 1 + n + sum n (fun i -> compute_size (Obj.field o i) (i::pos))
+ else if tag = Obj.string_tag then
+ 1 + n
+ else if tag = Obj.double_tag then
+ size_of_double
+ else if tag = Obj.double_array_tag then
+ size_of_double * n
+ else
+ 1
+ in
+ add_size o size pos;
+ size
+
+(** Provides the global object in which we'll search shared sizes *)
+
+let register_shared_size t =
+ let o = Obj.repr t in
+ reset_sizes ();
+ global_object := o;
+ ignore (compute_size o [])
+
+(** Shared size of an object with respect to the global object given
+ by the last [register_shared_size] *)
+
+let shared_size pos o =
+ if not (Obj.is_block o) then 0
+ else
+ let size,pos' =
+ try get_size o
+ with Not_found -> failwith "shared_size: unregistered structure ?"
+ in
+ match pos with
+ | Some p when p <> pos' -> 0
+ | _ -> size
+
+let shared_size_of_obj t = shared_size None (Obj.repr t)
+
+(** Shared size of the object at some positiion in the global object given
+ by the last [register_shared_size] *)
+
+let shared_size_of_pos pos =
+ let rec obj_of_pos o = function
+ | [] -> o
+ | n::pos' ->
+ let o' = obj_of_pos o pos' in
+ assert (Obj.is_block o' && n < Obj.size o');
+ Obj.field o' n
+ in
+ shared_size (Some pos) (obj_of_pos !global_object pos)
+
+
+(*s Total size of the allocated ocaml heap. *)
+
+let heap_size () =
+ let stat = Gc.stat ()
+ and control = Gc.get () in
+ let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in
+ (max_words_total * (Sys.word_size / 8))
+
+let heap_size_kb () = (heap_size () + 1023) / 1024
diff --git a/lib/cObj.mli b/lib/cObj.mli
new file mode 100644
index 00000000..16933a4a
--- /dev/null
+++ b/lib/cObj.mli
@@ -0,0 +1,59 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** {6 Physical size of an ocaml value.}
+
+ These functions explore objects recursively and may allocate a lot. *)
+
+val size : 'a -> int
+(** Physical size of an object in words. *)
+
+val size_b : 'a -> int
+(** Same as [size] in bytes. *)
+
+val size_kb : 'a -> int
+(** Same as [size] in kilobytes. *)
+
+(** {6 Physical size of an ocaml value with sharing.} *)
+
+(** This time, all the size of objects are computed with respect
+ to a larger object containing them all, and we only count
+ the new blocks not already seen earlier in the left-to-right
+ visit of the englobing object. *)
+
+(** Provides the global object in which we'll search shared sizes *)
+
+val register_shared_size : 'a -> unit
+
+(** Shared size (in word) of an object with respect to the global object
+ given by the last [register_shared_size]. *)
+
+val shared_size_of_obj : 'a -> int
+
+(** Same, with an object indicated by its occurrence in the global
+ object. The very same object could have a zero size or not, depending
+ of the occurrence we're considering in the englobing object.
+ For speaking of occurrences, we use an [int list] for a path
+ of field indexes (leftmost = deepest block, rightmost = top block of the
+ global object). *)
+
+val shared_size_of_pos : int list -> int
+
+(** {6 Logical size of an OCaml value.} *)
+
+val obj_stats : 'a -> int * int * int
+(** Return the (logical) value size, the string size, and the maximum depth of
+ the object. This loops on cyclic structures. *)
+
+(** {6 Total size of the allocated ocaml heap. } *)
+
+val heap_size : unit -> int
+(** Heap size, in words. *)
+
+val heap_size_kb : unit -> int
+(** Heap size, in kilobytes. *)
diff --git a/lib/cSet.ml b/lib/cSet.ml
new file mode 100644
index 00000000..d7d5c70b
--- /dev/null
+++ b/lib/cSet.ml
@@ -0,0 +1,67 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module type OrderedType =
+sig
+ type t
+ val compare : t -> t -> int
+end
+
+module type S = Set.S
+
+module Make(M : OrderedType)= Set.Make(M)
+
+module type HashedType =
+sig
+ type t
+ val hash : t -> int
+end
+
+module Hashcons(M : OrderedType)(H : HashedType with type t = M.t) =
+struct
+ module Set = Make(M)
+
+ type set = Set.t
+ type _set =
+ | SEmpty
+ | SNode of set * M.t * set * int
+
+ let set_prj : set -> _set = Obj.magic
+ let set_inj : _set -> set = Obj.magic
+
+ let rec spine s accu = match set_prj s with
+ | SEmpty -> accu
+ | SNode (l, v, r, _) -> spine l ((v, r) :: accu)
+
+ let rec umap f s = match set_prj s with
+ | SEmpty -> set_inj SEmpty
+ | SNode (l, v, r, h) ->
+ let l' = umap f l in
+ let r' = umap f r in
+ let v' = f v in
+ set_inj (SNode (l', v', r', h))
+
+ let rec eqeq s1 s2 = match s1, s2 with
+ | [], [] -> true
+ | (v1, r1) :: s1, (v2, r2) :: s2 ->
+ v1 == v2 && eqeq (spine r1 s1) (spine r2 s2)
+ | _ -> false
+
+ module Hashed =
+ struct
+ open Hashset.Combine
+ type t = set
+ type u = M.t -> M.t
+ let equal s1 s2 = s1 == s2 || eqeq (spine s1 []) (spine s2 [])
+ let hash s = Set.fold (fun v accu -> combine (H.hash v) accu) s 0
+ let hashcons = umap
+ end
+
+ include Hashcons.Make(Hashed)
+
+end
diff --git a/lib/cSet.mli b/lib/cSet.mli
new file mode 100644
index 00000000..e5505410
--- /dev/null
+++ b/lib/cSet.mli
@@ -0,0 +1,31 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module type OrderedType =
+sig
+ type t
+ val compare : t -> t -> int
+end
+
+module type S = Set.S
+
+module Make(M : OrderedType) : S
+ with type elt = M.t
+ and type t = Set.Make(M).t
+
+module type HashedType =
+sig
+ type t
+ val hash : t -> int
+end
+
+module Hashcons (M : OrderedType) (H : HashedType with type t = M.t) : Hashcons.S with
+ type t = Set.Make(M).t
+ and type u = M.t -> M.t
+(** Create hash-consing for sets. The hashing function provided must be
+ compatible with the comparison function. *)
diff --git a/lib/cSig.mli b/lib/cSig.mli
new file mode 100644
index 00000000..2a8bda29
--- /dev/null
+++ b/lib/cSig.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Missing pervasive types from OCaml stdlib *)
+
+type ('a, 'b) union = Inl of 'a | Inr of 'b
+(** Union type *)
+
+type 'a until = Stop of 'a | Cont of 'a
+(** Used for browsable-until structures. *)
+
+module type SetS =
+sig
+ type elt
+ type t
+ val empty: t
+ val is_empty: t -> bool
+ val mem: elt -> t -> bool
+ val add: elt -> t -> t
+ val singleton: elt -> t
+ val remove: elt -> t -> t
+ val union: t -> t -> t
+ val inter: t -> t -> t
+ val diff: t -> t -> t
+ val compare: t -> t -> int
+ val equal: t -> t -> bool
+ val subset: t -> t -> bool
+ val iter: (elt -> unit) -> t -> unit
+ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+ val for_all: (elt -> bool) -> t -> bool
+ val exists: (elt -> bool) -> t -> bool
+ val filter: (elt -> bool) -> t -> t
+ val partition: (elt -> bool) -> t -> t * t
+ val cardinal: t -> int
+ val elements: t -> elt list
+ val min_elt: t -> elt
+ val max_elt: t -> elt
+ val choose: t -> elt
+ val split: elt -> t -> t * bool * t
+end
+(** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml
+ documentation for more information. *)
diff --git a/lib/cStack.ml b/lib/cStack.ml
new file mode 100644
index 00000000..4acb2930
--- /dev/null
+++ b/lib/cStack.ml
@@ -0,0 +1,42 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+exception Empty = Stack.Empty
+
+type 'a t = {
+ mutable stack : 'a list;
+}
+
+let create () = { stack = [] }
+
+let push x s = s.stack <- x :: s.stack
+
+let pop = function
+ | { stack = [] } -> raise Stack.Empty
+ | { stack = x::xs } as s -> s.stack <- xs; x
+
+let top = function
+ | { stack = [] } -> raise Stack.Empty
+ | { stack = x::_ } -> x
+
+let to_list { stack = s } = s
+
+let find f s = List.find f (to_list s)
+
+let find_map f s = CList.find_map f s.stack
+
+let fold_until f accu s = CList.fold_left_until f accu s.stack
+
+let is_empty { stack = s } = s = []
+
+let iter f { stack = s } = List.iter f s
+
+let clear s = s.stack <- []
+
+let length { stack = s } = List.length s
+
diff --git a/lib/cStack.mli b/lib/cStack.mli
new file mode 100644
index 00000000..8dde1d1a
--- /dev/null
+++ b/lib/cStack.mli
@@ -0,0 +1,56 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Extended interface for OCaml stacks. *)
+
+type 'a t
+
+exception Empty
+(** Alias for Stack.Empty. *)
+
+val create : unit -> 'a t
+(** Create an empty stack. *)
+
+val push : 'a -> 'a t -> unit
+(** Add an element to a stack. *)
+
+val find : ('a -> bool) -> 'a t -> 'a
+(** Find the first element satisfying the predicate.
+ @raise Not_found it there is none. *)
+
+val is_empty : 'a t -> bool
+(** Whether a stack is empty. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** Iterate a function over elements, from the last added one. *)
+
+val clear : 'a t -> unit
+(** Empty a stack. *)
+
+val length : 'a t -> int
+(** Length of a stack. *)
+
+val pop : 'a t -> 'a
+(** Remove and returns the first element of the stack.
+ @raise Empty if empty. *)
+
+val top : 'a t -> 'a
+(** Remove the first element of the stack without modifying it.
+ @raise Empty if empty. *)
+
+val to_list : 'a t -> 'a list
+(** Convert to a list. *)
+
+val find_map : ('a -> 'b option) -> 'a t -> 'b
+(** Find the first element that returns [Some _].
+ @raise Not_found it there is none. *)
+
+val fold_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a t -> 'c
+(** Like CList.fold_left_until.
+ The stack is traversed from the top and is not altered. *)
+
diff --git a/lib/cString.ml b/lib/cString.ml
new file mode 100644
index 00000000..250b7cee
--- /dev/null
+++ b/lib/cString.ml
@@ -0,0 +1,174 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module type S = module type of String
+
+module type ExtS =
+sig
+ include S
+ external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+ val hash : string -> int
+ val is_empty : string -> bool
+ val explode : string -> string list
+ val implode : string list -> string
+ val strip : string -> string
+ val map : (char -> char) -> string -> string
+ val drop_simple_quotes : string -> string
+ val string_index_from : string -> int -> string -> int
+ val string_contains : where:string -> what:string -> bool
+ val plural : int -> string -> string
+ val conjugate_verb_to_be : int -> string
+ val ordinal : int -> string
+ val split : char -> string -> string list
+ val is_sub : string -> string -> int -> bool
+ module Set : Set.S with type elt = t
+ module Map : CMap.ExtS with type key = t and module Set := Set
+ module List : CList.MonoS with type elt = t
+ val hcons : string -> string
+end
+
+include String
+
+external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+
+let rec hash len s i accu =
+ if i = len then accu
+ else
+ let c = Char.code (String.unsafe_get s i) in
+ hash len s (succ i) (accu * 19 + c)
+
+let hash s =
+ let len = String.length s in
+ hash len s 0 0
+
+let explode s =
+ let rec explode_rec n =
+ if n >= String.length s then
+ []
+ else
+ String.make 1 (String.get s n) :: explode_rec (succ n)
+ in
+ explode_rec 0
+
+let implode sl = String.concat "" sl
+
+let is_blank = function
+ | ' ' | '\r' | '\t' | '\n' -> true
+ | _ -> false
+
+let is_empty s = String.length s = 0
+
+let strip s =
+ let n = String.length s in
+ let rec lstrip_rec i =
+ if i < n && is_blank s.[i] then
+ lstrip_rec (i+1)
+ else i
+ in
+ let rec rstrip_rec i =
+ if i >= 0 && is_blank s.[i] then
+ rstrip_rec (i-1)
+ else i
+ in
+ let a = lstrip_rec 0 and b = rstrip_rec (n-1) in
+ String.sub s a (b-a+1)
+
+let map f s =
+ let l = String.length s in
+ let r = String.create l in
+ for i = 0 to (l - 1) do r.[i] <- f (s.[i]) done;
+ r
+
+let drop_simple_quotes s =
+ let n = String.length s in
+ if n > 2 && s.[0] = '\'' && s.[n-1] = '\'' then String.sub s 1 (n-2) else s
+
+(* substring searching... *)
+
+(* gdzie = where, co = what *)
+(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
+let rec raw_is_sub gdzie gl gi co cl ci =
+ (ci>=cl) ||
+ ((String.unsafe_get gdzie gi = String.unsafe_get co ci) &&
+ (raw_is_sub gdzie gl (gi+1) co cl (ci+1)))
+
+let rec raw_str_index i gdzie l c co cl =
+ (* First adapt to ocaml 3.11 new semantics of index_from *)
+ if (i+cl > l) then raise Not_found;
+ (* Then proceed as in ocaml < 3.11 *)
+ let i' = String.index_from gdzie i c in
+ if (i'+cl <= l) && (raw_is_sub gdzie l i' co cl 0) then i' else
+ raw_str_index (i'+1) gdzie l c co cl
+
+let string_index_from gdzie i co =
+ if co="" then i else
+ raw_str_index i gdzie (String.length gdzie)
+ (String.unsafe_get co 0) co (String.length co)
+
+let string_contains ~where ~what =
+ try
+ let _ = string_index_from where 0 what in true
+ with
+ Not_found -> false
+
+let is_sub p s off =
+ let lp = String.length p in
+ let ls = String.length s in
+ if ls < off + lp then false
+ else
+ let rec aux i =
+ if lp <= i then true
+ else
+ let cp = String.unsafe_get p i in
+ let cs = String.unsafe_get s (off + i) in
+ if cp = cs then aux (succ i) else false
+ in
+ aux 0
+
+let plural n s = if n<>1 then s^"s" else s
+
+let conjugate_verb_to_be n = if n<>1 then "are" else "is"
+
+let ordinal n =
+ let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in
+ string_of_int n ^ s
+
+(* string parsing *)
+
+let split c s =
+ let len = String.length s in
+ let rec split n =
+ try
+ let pos = String.index_from s n c in
+ let dir = String.sub s n (pos-n) in
+ dir :: split (succ pos)
+ with
+ | Not_found -> [String.sub s n (len-n)]
+ in
+ if Int.equal len 0 then [] else split 0
+
+module Self =
+struct
+ type t = string
+ let compare = compare
+end
+
+module Set = Set.Make(Self)
+module Map = CMap.Make(Self)
+
+module List = struct
+ type elt = string
+ let mem id l = List.exists (fun s -> equal id s) l
+ let assoc id l = CList.assoc_f equal id l
+ let remove_assoc id l = CList.remove_assoc_f equal id l
+ let mem_assoc id l = List.exists (fun (a,_) -> equal id a) l
+ let mem_assoc_sym id l = List.exists (fun (_,b) -> equal id b) l
+ let equal l l' = CList.equal equal l l'
+end
+
+let hcons = Hashcons.simple_hcons Hashcons.Hstring.generate Hashcons.Hstring.hcons ()
diff --git a/lib/cString.mli b/lib/cString.mli
new file mode 100644
index 00000000..4fa9e1e9
--- /dev/null
+++ b/lib/cString.mli
@@ -0,0 +1,78 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Module type [S] is the one from OCaml Stdlib. *)
+module type S = module type of String
+
+module type ExtS =
+sig
+ include S
+ (** We include the standard library *)
+
+ external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+ (** Equality on strings *)
+
+ val hash : string -> int
+ (** Hashing on strings. Should be compatible with generic one. *)
+
+ val is_empty : string -> bool
+ (** Test whether a string is empty. *)
+
+ val explode : string -> string list
+ (** [explode "x1...xn"] returns [["x1"; ...; "xn"]] *)
+
+ val implode : string list -> string
+ (** [implode [s1; ...; sn]] returns [s1 ^ ... ^ sn] *)
+
+ val strip : string -> string
+ (** Remove the surrounding blank characters from a string *)
+
+ val map : (char -> char) -> string -> string
+ (** Apply a function on a string character-wise. *)
+
+ val drop_simple_quotes : string -> string
+ (** Remove the eventual first surrounding simple quotes of a string. *)
+
+ val string_index_from : string -> int -> string -> int
+ (** As [index_from], but takes a string instead of a char as pattern argument *)
+
+ val string_contains : where:string -> what:string -> bool
+ (** As [contains], but takes a string instead of a char as pattern argument *)
+
+ val plural : int -> string -> string
+ (** [plural n s] adds a optional 's' to the [s] when [2 <= n]. *)
+
+ val conjugate_verb_to_be : int -> string
+ (** [conjugate_verb_to_be] returns "is" when [n=1] and "are" otherwise *)
+
+ val ordinal : int -> string
+ (** Generate the ordinal number in English. *)
+
+ val split : char -> string -> string list
+ (** [split c s] splits [s] into sequences separated by [c], excluded. *)
+
+ val is_sub : string -> string -> int -> bool
+ (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *)
+
+ (** {6 Generic operations} **)
+
+ module Set : Set.S with type elt = t
+ (** Finite sets on [string] *)
+
+ module Map : CMap.ExtS with type key = t and module Set := Set
+ (** Finite maps on [string] *)
+
+ module List : CList.MonoS with type elt = t
+ (** Association lists with [string] as keys *)
+
+ val hcons : string -> string
+ (** Hashconsing on [string] *)
+
+end
+
+include ExtS
diff --git a/lib/cThread.ml b/lib/cThread.ml
new file mode 100644
index 00000000..55bb6fd6
--- /dev/null
+++ b/lib/cThread.ml
@@ -0,0 +1,76 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type thread_ic = in_channel
+
+let prepare_in_channel_for_thread_friendly_io ic =
+ Unix.set_nonblock (Unix.descr_of_in_channel ic); ic
+
+let safe_wait_timed_read fd time =
+ try Thread.wait_timed_read fd time
+ with Unix.Unix_error (Unix.EINTR, _, _) ->
+ (** On Unix, the above function may raise this exception when it is
+ interrupted by a signal. (It uses Unix.select internally.) *)
+ false
+
+let thread_friendly_read_fd fd s ~off ~len =
+ let rec loop () =
+ try Unix.read fd s off len
+ with Unix.Unix_error((Unix.EWOULDBLOCK|Unix.EAGAIN|Unix.EINTR),_,_) ->
+ while not (safe_wait_timed_read fd 1.0) do Thread.yield () done;
+ loop ()
+ in
+ loop ()
+
+let thread_friendly_read ic s ~off ~len =
+ try
+ let fd = Unix.descr_of_in_channel ic in
+ thread_friendly_read_fd fd s ~off ~len
+ with Unix.Unix_error _ -> 0
+
+let really_read_fd fd s off len =
+ let i = ref 0 in
+ while !i < len do
+ let off = off + !i in
+ let len = len - !i in
+ let r = thread_friendly_read_fd fd s ~off ~len in
+ if r = 0 then raise End_of_file;
+ i := !i + r
+ done
+
+let thread_friendly_really_read ic s ~off ~len =
+ try
+ let fd = Unix.descr_of_in_channel ic in
+ really_read_fd fd s off len
+ with Unix.Unix_error _ -> raise End_of_file
+
+let thread_friendly_really_read_line ic =
+ try
+ let fd = Unix.descr_of_in_channel ic in
+ let b = Buffer.create 1024 in
+ let s = String.make 1 '\000' in
+ while s <> "\n" do
+ let n = thread_friendly_read_fd fd s ~off:0 ~len:1 in
+ if n = 0 then raise End_of_file;
+ if s <> "\n" then Buffer.add_string b s;
+ done;
+ Buffer.contents b
+ with Unix.Unix_error _ -> raise End_of_file
+
+let thread_friendly_input_value ic =
+ try
+ let fd = Unix.descr_of_in_channel ic in
+ let header = String.create Marshal.header_size in
+ really_read_fd fd header 0 Marshal.header_size;
+ let body_size = Marshal.data_size header 0 in
+ let msg = String.create (body_size + Marshal.header_size) in
+ String.blit header 0 msg 0 Marshal.header_size;
+ really_read_fd fd msg Marshal.header_size body_size;
+ Marshal.from_string msg 0
+ with Unix.Unix_error _ -> raise End_of_file
+
diff --git a/lib/cThread.mli b/lib/cThread.mli
new file mode 100644
index 00000000..8b110f3f
--- /dev/null
+++ b/lib/cThread.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* As of OCaml 4.01.0 input_value and input do not quite work well
+ * with threads. The symptom is the following. Two threads, each
+ * of them blocked on a read (on different channels). One is not
+ * woken up even if data is available. When the other one gets data
+ * then the stuck one is eventually unblocked too. Unix.select with
+ * an unbounded wait has the same problem. *)
+
+(* Use only the following functions on the channel *)
+type thread_ic
+val prepare_in_channel_for_thread_friendly_io : in_channel -> thread_ic
+
+val thread_friendly_input_value : thread_ic -> 'a
+val thread_friendly_read :
+ thread_ic -> string -> off:int -> len:int -> int
+val thread_friendly_really_read :
+ thread_ic -> string -> off:int -> len:int -> unit
+val thread_friendly_really_read_line : thread_ic -> string
+
diff --git a/lib/cUnix.ml b/lib/cUnix.ml
new file mode 100644
index 00000000..4a1fc762
--- /dev/null
+++ b/lib/cUnix.ml
@@ -0,0 +1,139 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Files and load path. *)
+
+type physical_path = string
+type load_path = physical_path list
+
+let physical_path_of_string s = s
+let string_of_physical_path p = p
+
+let path_to_list p =
+ let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in
+ Str.split sep p
+
+(* Some static definitions concerning filenames *)
+
+let dirsep = Filename.dir_sep (* Unix: "/" *)
+let dirsep_len = String.length dirsep
+let curdir = Filename.concat Filename.current_dir_name "" (* Unix: "./" *)
+let curdir_len = String.length curdir
+
+(* Hints to partially detects if two paths refer to the same directory *)
+
+(** cut path [p] after all the [/] that come at position [pos]. *)
+let rec cut_after_dirsep p pos =
+ if CString.is_sub dirsep p pos then
+ cut_after_dirsep p (pos + dirsep_len)
+ else
+ String.sub p pos (String.length p - pos)
+
+(** remove all initial "./" in a path unless the path is exactly "./" *)
+let rec remove_path_dot p =
+ if CString.is_sub curdir p 0 then
+ if String.length p = curdir_len
+ then Filename.current_dir_name
+ else remove_path_dot (cut_after_dirsep p curdir_len)
+ else
+ p
+
+(** If a path [p] starts with the current directory $PWD then
+ [strip_path p] returns the sub-path relative to $PWD.
+ Any leading "./" are also removed from the result. *)
+let strip_path p =
+ let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
+ if CString.is_sub cwd p 0 then
+ remove_path_dot (cut_after_dirsep p (String.length cwd))
+ else
+ remove_path_dot p
+
+let canonical_path_name p =
+ let current = Sys.getcwd () in
+ try
+ Sys.chdir p;
+ let p' = Sys.getcwd () in
+ Sys.chdir current;
+ p'
+ with Sys_error _ ->
+ (* We give up to find a canonical name and just simplify it... *)
+ strip_path p
+
+let make_suffix name suffix =
+ if Filename.check_suffix name suffix then name else (name ^ suffix)
+
+let get_extension f =
+ let pos = try String.rindex f '.' with Not_found -> String.length f in
+ String.sub f pos (String.length f - pos)
+
+let correct_path f dir =
+ if Filename.is_relative f then Filename.concat dir f else f
+
+let file_readable_p name =
+ try Unix.access name [Unix.R_OK];true
+ with Unix.Unix_error (_, _, _) -> false
+
+(* As for [Unix.close_process], a [Unix.waipid] that ignores all [EINTR] *)
+
+let rec waitpid_non_intr pid =
+ try snd (Unix.waitpid [] pid)
+ with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid
+
+(** [run_command com] launches command [com] (via /bin/sh),
+ and returns the contents of stdout and stderr. If given, [~hook]
+ is called on each elements read on stdout or stderr. *)
+
+let run_command ?(hook=(fun _ ->())) c =
+ let result = Buffer.create 127 in
+ let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
+ let buff = String.make 127 ' ' in
+ let buffe = String.make 127 ' ' in
+ let n = ref 0 in
+ let ne = ref 0 in
+ while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ;
+ !n+ !ne <> 0
+ do
+ let r = String.sub buff 0 !n in (hook r; Buffer.add_string result r);
+ let r = String.sub buffe 0 !ne in (hook r; Buffer.add_string result r);
+ done;
+ (Unix.close_process_full (cin,cout,cerr), Buffer.contents result)
+
+(** [sys_command] launches program [prog] with arguments [args].
+ It behaves like [Sys.command], except that we rely on
+ [Unix.create_process], it's hardly more complex and avoids dealing
+ with shells. In particular, no need to quote arguments
+ (against whitespace or other funny chars in paths), hence no need
+ to care about the different quoting conventions of /bin/sh and cmd.exe. *)
+
+let sys_command prog args =
+ let argv = Array.of_list (prog::args) in
+ let pid = Unix.create_process prog argv Unix.stdin Unix.stdout Unix.stderr in
+ waitpid_non_intr pid
+
+(*
+ checks if two file names refer to the same (existing) file by
+ comparing their device and inode.
+ It seems that under Windows, inode is always 0, so we cannot
+ accurately check if
+
+*)
+(* Optimised for partial application (in case many candidates must be
+ compared to f1). *)
+let same_file f1 =
+ try
+ let s1 = Unix.stat f1 in
+ (fun f2 ->
+ try
+ let s2 = Unix.stat f2 in
+ s1.Unix.st_dev = s2.Unix.st_dev &&
+ if Sys.os_type = "Win32" then f1 = f2
+ else s1.Unix.st_ino = s2.Unix.st_ino
+ with
+ Unix.Unix_error _ -> false)
+ with
+ Unix.Unix_error _ -> (fun _ -> false)
diff --git a/lib/cUnix.mli b/lib/cUnix.mli
new file mode 100644
index 00000000..2d0d202d
--- /dev/null
+++ b/lib/cUnix.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** {5 System utilities} *)
+
+type physical_path = string
+type load_path = physical_path list
+
+val physical_path_of_string : string -> physical_path
+val string_of_physical_path : physical_path -> string
+
+val canonical_path_name : string -> string
+
+(** remove all initial "./" in a path *)
+val remove_path_dot : string -> string
+
+(** If a path [p] starts with the current directory $PWD then
+ [strip_path p] returns the sub-path relative to $PWD.
+ Any leading "./" are also removed from the result. *)
+val strip_path : string -> string
+
+(** correct_path f dir = dir/f if f is relative *)
+val correct_path : string -> string -> string
+
+val path_to_list : string -> string list
+
+(** [make_suffix file suf] catenate [file] with [suf] when
+ [file] does not already end with [suf]. *)
+val make_suffix : string -> string -> string
+
+(** Return the extension of a file, i.e. its smaller suffix starting
+ with "." if any, or "" otherwise. *)
+val get_extension : string -> string
+
+val file_readable_p : string -> bool
+
+(** {6 Executing commands } *)
+
+(** [run_command com] launches command [com], and returns
+ the contents of stdout and stderr. If given, [~hook]
+ is called on each elements read on stdout or stderr. *)
+
+val run_command :
+ ?hook:(string->unit) -> string -> Unix.process_status * string
+
+(** [sys_command] launches program [prog] with arguments [args].
+ It behaves like [Sys.command], except that we rely on
+ [Unix.create_process], it's hardly more complex and avoids dealing
+ with shells. In particular, no need to quote arguments
+ (against whitespace or other funny chars in paths), hence no need
+ to care about the different quoting conventions of /bin/sh and cmd.exe. *)
+
+val sys_command : string -> string list -> Unix.process_status
+
+(** A version of [Unix.waitpid] immune to EINTR exceptions *)
+
+val waitpid_non_intr : int -> Unix.process_status
+
+(** checks if two file names refer to the same (existing) file *)
+val same_file : string -> string -> bool
+
diff --git a/lib/gmapl.ml b/lib/canary.ml
index 987ff9af..23d7bd21 100644
--- a/lib/gmapl.ml
+++ b/lib/canary.ml
@@ -1,33 +1,26 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Util
+type t = Obj.t
-type ('a,'b) t = ('a,'b list) Gmap.t
+let obj = Obj.new_block Obj.closure_tag 0
+ (** This is an empty closure block. In the current implementation, it is
+ sufficient to allow marshalling but forbid equality. Sadly still allows
+ hash. *)
+ (** FIXME : use custom blocks somehow. *)
-let empty = Gmap.empty
-let mem = Gmap.mem
-let iter = Gmap.iter
-let map = Gmap.map
-let fold = Gmap.fold
-
-let add x y m =
- try
- let l = Gmap.find x m in
- Gmap.add x (y::list_except y l) m
- with Not_found ->
- Gmap.add x [y] m
-
-let find x m =
- try Gmap.find x m with Not_found -> []
-
-let remove x y m =
- let l = Gmap.find x m in
- Gmap.add x (if List.mem y l then list_subtract l [y] else l) m
+module type Obj = sig type t end
+module Make(M : Obj) =
+struct
+ type canary = t
+ type t = (canary * M.t)
+ let prj (_, x) = x
+ let inj x = (obj, x)
+end
diff --git a/lib/gmapl.mli b/lib/canary.mli
index 5b81459b..c0ba86a7 100644
--- a/lib/gmapl.mli
+++ b/lib/canary.mli
@@ -1,21 +1,25 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(** Maps from ['a] to lists of ['b]. *)
+type t
+(** Type of canaries. Canaries are used to ensure that an object does not use
+ generic operations. *)
-type ('a,'b) t
+val obj : t
+(** Canary. In the current implementation, this object is marshallable,
+ forbids generic comparison but still allows generic hashes. *)
-val empty : ('a,'b) t
-val mem : 'a -> ('a,'b) t -> bool
-val iter : ('a -> 'b list -> unit) -> ('a,'b) t -> unit
-val map : ('b list -> 'c list) -> ('a,'b) t -> ('a,'c) t
-val fold : ('a -> 'b list -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
+module type Obj = sig type t end
-val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
-val find : 'a -> ('a,'b) t -> 'b list
-val remove : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
+module Make(M : Obj) :
+sig
+ type t
+ val prj : t -> M.t
+ val inj : M.t -> t
+end
+(** Adds a canary to any type. *)
diff --git a/lib/clib.mllib b/lib/clib.mllib
new file mode 100644
index 00000000..2da81c95
--- /dev/null
+++ b/lib/clib.mllib
@@ -0,0 +1,39 @@
+Coq_config
+
+Terminal
+Canary
+Hook
+Hashset
+Hashcons
+CSet
+CMap
+Int
+HMap
+Option
+Store
+Exninfo
+Backtrace
+IStream
+Pp_control
+Flags
+Control
+Loc
+Serialize
+Deque
+CObj
+CList
+CString
+CArray
+CStack
+Util
+Stateid
+Feedback
+Pp
+Xml_lexer
+Xml_parser
+Xml_printer
+Richpp
+CUnix
+Envars
+Aux_file
+Monad
diff --git a/lib/compat.ml4 b/lib/compat.ml4
deleted file mode 100644
index 73cbc6d6..00000000
--- a/lib/compat.ml4
+++ /dev/null
@@ -1,242 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** Compatibility file depending on ocaml/camlp4 version *)
-
-(** Locations *)
-
-IFDEF CAMLP5 THEN
-
-module Loc = struct
- include Ploc
- exception Exc_located = Exc
- let ghost = dummy
- let merge = encl
-end
-
-let make_loc = Loc.make_unlined
-let unloc loc = (Loc.first_pos loc, Loc.last_pos loc)
-
-ELSE
-
-module Loc = Camlp4.PreCast.Loc
-
-let make_loc (start,stop) =
- Loc.of_tuple ("", 0, 0, start, 0, 0, stop, false)
-let unloc loc = (Loc.start_off loc, Loc.stop_off loc)
-
-END
-
-(** Misc module emulation *)
-
-IFDEF CAMLP5 THEN
-
-module PcamlSig = struct end
-
-ELSE
-
-module PcamlSig = Camlp4.Sig
-module Ast = Camlp4.PreCast.Ast
-module Pcaml = Camlp4.PreCast.Syntax
-module MLast = Ast
-module Token = struct exception Error of string end
-
-END
-
-
-(** Grammar auxiliary types *)
-
-IFDEF CAMLP5 THEN
-type gram_assoc = Gramext.g_assoc = NonA | RightA | LeftA
-type gram_position = Gramext.position =
- | First
- | Last
- | Before of string
- | After of string
- | Like of string (** dont use it, not in camlp4 *)
- | Level of string
-ELSE
-type gram_assoc = PcamlSig.Grammar.assoc = NonA | RightA | LeftA
-type gram_position = PcamlSig.Grammar.position =
- | First
- | Last
- | Before of string
- | After of string
- | Level of string
-END
-
-
-(** Signature of Lexer *)
-
-IFDEF CAMLP5 THEN
-
-module type LexerSig = sig
- include Grammar.GLexerType with type te = Tok.t
- module Error : sig
- type t
- exception E of t
- val to_string : t -> string
- end
-end
-
-ELSE
-
-module type LexerSig =
- Camlp4.Sig.Lexer with module Loc = Loc and type Token.t = Tok.t
-
-END
-
-(** Signature and implementation of grammars *)
-
-IFDEF CAMLP5 THEN
-
-module type GrammarSig = sig
- include Grammar.S with type te = Tok.t
- type 'a entry = 'a Entry.e
- type internal_entry = Tok.t Gramext.g_entry
- type symbol = Tok.t Gramext.g_symbol
- type action = Gramext.g_action
- type production_rule = symbol list * action
- type single_extend_statment =
- string option * gram_assoc option * production_rule list
- type extend_statment =
- gram_position option * single_extend_statment list
- val action : 'a -> action
- val entry_create : string -> 'a entry
- val entry_parse : 'a entry -> parsable -> 'a
- val entry_print : 'a entry -> unit
- val srules' : production_rule list -> symbol
- val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a
-end
-
-module GrammarMake (L:LexerSig) : GrammarSig = struct
- include Grammar.GMake (L)
- type 'a entry = 'a Entry.e
- type internal_entry = Tok.t Gramext.g_entry
- type symbol = Tok.t Gramext.g_symbol
- type action = Gramext.g_action
- type production_rule = symbol list * action
- type single_extend_statment =
- string option * gram_assoc option * production_rule list
- type extend_statment =
- gram_position option * single_extend_statment list
- let action = Gramext.action
- let entry_create = Entry.create
- let entry_parse = Entry.parse
-IFDEF CAMLP5_6_02_1 THEN
- let entry_print x = Entry.print !Pp_control.std_ft x
-ELSE
- let entry_print = Entry.print
-END
- let srules' = Gramext.srules
- let parse_tokens_after_filter = Entry.parse_token
-end
-
-ELSE
-
-module type GrammarSig = sig
- include Camlp4.Sig.Grammar.Static
- with module Loc = Loc and type Token.t = Tok.t
- type 'a entry = 'a Entry.t
- type action = Action.t
- type parsable
- val parsable : char Stream.t -> parsable
- val action : 'a -> action
- val entry_create : string -> 'a entry
- val entry_parse : 'a entry -> parsable -> 'a
- val entry_print : 'a entry -> unit
- val srules' : production_rule list -> symbol
-end
-
-module GrammarMake (L:LexerSig) : GrammarSig = struct
- include Camlp4.Struct.Grammar.Static.Make (L)
- type 'a entry = 'a Entry.t
- type action = Action.t
- type parsable = char Stream.t
- let parsable s = s
- let action = Action.mk
- let entry_create = Entry.mk
- let entry_parse e s = parse e (*FIXME*)Loc.ghost s
- let entry_print x = Entry.print !Pp_control.std_ft x
- let srules' = srules (entry_create "dummy")
-end
-
-END
-
-
-(** Misc functional adjustments *)
-
-(** - The lexer produces streams made of pairs in camlp4 *)
-
-let get_tok = IFDEF CAMLP5 THEN fun x -> x ELSE fst END
-
-(** - Gram.extend is more currified in camlp5 than in camlp4 *)
-
-IFDEF CAMLP5 THEN
-let maybe_curry f x y = f (x,y)
-let maybe_uncurry f (x,y) = f x y
-ELSE
-let maybe_curry f = f
-let maybe_uncurry f = f
-END
-
-(** Compatibility with camlp5 strict mode *)
-IFDEF CAMLP5 THEN
- IFDEF STRICT THEN
- let vala x = Ploc.VaVal x
- ELSE
- let vala x = x
- END
-ELSE
- let vala x = x
-END
-
-(** Fix a quotation difference in [str_item] *)
-
-let declare_str_items loc l =
-IFDEF CAMLP5 THEN
- MLast.StDcl (loc, vala l) (* correspond to <:str_item< declare $list:l'$ end >> *)
-ELSE
- Ast.stSem_of_list l
-END
-
-(** Quotation difference for match clauses *)
-
-let default_patt loc =
- (<:patt< _ >>, vala None, <:expr< failwith "Extension: cannot occur" >>)
-
-IFDEF CAMLP5 THEN
-
-let make_fun loc cl =
- let l = cl @ [default_patt loc] in
- MLast.ExFun (loc, vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *)
-
-ELSE
-
-let make_fun loc cl =
- let mk_when = function
- | Some w -> w
- | None -> Ast.ExNil loc
- in
- let mk_clause (patt,optwhen,expr) =
- (* correspond to <:match_case< ... when ... -> ... >> *)
- Ast.McArr (loc, patt, mk_when optwhen, expr) in
- let init = mk_clause (default_patt loc) in
- let add_clause x acc = Ast.McOr (loc, mk_clause x, acc) in
- let l = List.fold_right add_clause cl init in
- Ast.ExFun (loc,l) (* correspond to <:expr< fun [ $l$ ] >> *)
-
-END
-
-(** Explicit antiquotation $anti:... $ *)
-
-IFDEF CAMLP5 THEN
-let expl_anti loc e = <:expr< $anti:e$ >>
-ELSE
-let expl_anti _loc e = e (* FIXME: understand someday if we can do better *)
-END
diff --git a/lib/control.ml b/lib/control.ml
new file mode 100644
index 00000000..673a75a2
--- /dev/null
+++ b/lib/control.ml
@@ -0,0 +1,91 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*s interruption *)
+
+let interrupt = ref false
+
+let steps = ref 0
+
+let are_we_threading = lazy (
+ match !Flags.async_proofs_mode with
+ | Flags.APon -> true
+ | _ -> false)
+
+let check_for_interrupt () =
+ if !interrupt then begin interrupt := false; raise Sys.Break end;
+ incr steps;
+ if !steps = 1000 && Lazy.force are_we_threading then begin
+ Thread.delay 0.001;
+ steps := 0;
+ end
+
+(** This function does not work on windows, sigh... *)
+let unix_timeout n f e =
+ let timeout_handler _ = raise e in
+ let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in
+ let _ = Unix.alarm n in
+ let restore_timeout () =
+ let _ = Unix.alarm 0 in
+ Sys.set_signal Sys.sigalrm psh
+ in
+ try
+ let res = f () in
+ restore_timeout ();
+ res
+ with e ->
+ let e = Backtrace.add_backtrace e in
+ restore_timeout ();
+ Exninfo.iraise e
+
+let windows_timeout n f e =
+ let killed = ref false in
+ let exited = ref false in
+ let thread init =
+ while not !killed do
+ let cur = Unix.time () in
+ if float_of_int n <= cur -. init then begin
+ interrupt := true;
+ exited := true;
+ Thread.exit ()
+ end;
+ Thread.delay 0.5
+ done
+ in
+ let init = Unix.time () in
+ let _id = Thread.create thread init in
+ try
+ let res = f () in
+ let () = killed := true in
+ let cur = Unix.time () in
+ (** The thread did not interrupt, but the computation took longer than
+ expected. *)
+ let () = if float_of_int n <= cur -. init then begin
+ exited := true;
+ raise Sys.Break
+ end in
+ res
+ with
+ | Sys.Break ->
+ (** Just in case, it could be a regular Ctrl+C *)
+ if not !exited then begin killed := true; raise Sys.Break end
+ else raise e
+ | e ->
+ let () = killed := true in
+ let e = Backtrace.add_backtrace e in
+ Exninfo.iraise e
+
+type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a }
+
+let timeout_fun = match Sys.os_type with
+| "Unix" | "Cygwin" -> ref { timeout = unix_timeout }
+| _ -> ref { timeout = windows_timeout }
+
+let set_timeout f = timeout_fun := f
+
+let timeout n f e = !timeout_fun.timeout n f e
diff --git a/lib/control.mli b/lib/control.mli
new file mode 100644
index 00000000..2a496bca
--- /dev/null
+++ b/lib/control.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Global control of Coq. *)
+
+val interrupt : bool ref
+(** Coq interruption: set the following boolean reference to interrupt Coq
+ (it eventually raises [Break], simulating a Ctrl-C) *)
+
+val check_for_interrupt : unit -> unit
+(** Use this function as a potential yield function. If {!interrupt} has been
+ set, il will raise [Sys.Break]. *)
+
+val timeout : int -> (unit -> 'a) -> exn -> 'a
+(** [timeout n f e] tries to compute [f], and if it fails to do so before [n]
+ seconds, it raises [e] instead. *)
+
+type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a }
+
+val set_timeout : timeout -> unit
+(** Set a particular timeout function. *)
diff --git a/lib/deque.ml b/lib/deque.ml
new file mode 100644
index 00000000..c04d5993
--- /dev/null
+++ b/lib/deque.ml
@@ -0,0 +1,97 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+exception Empty
+
+type 'a t = {
+ face : 'a list;
+ rear : 'a list;
+ lenf : int;
+ lenr : int;
+}
+
+let rec split i accu l = match l with
+| [] ->
+ if Int.equal i 0 then (accu, []) else invalid_arg "split"
+| t :: q ->
+ if Int.equal i 0 then (accu, l)
+ else split (pred i) (t :: accu) q
+
+let balance q =
+ let avg = (q.lenf + q.lenr) / 2 in
+ let dif = q.lenf + q.lenr - avg in
+ if q.lenf > succ (2 * q.lenr) then
+ let (ff, fr) = split avg [] q.face in
+ { face = List.rev ff ; rear = q.rear @ List.rev fr; lenf = avg; lenr = dif }
+ else if q.lenr > succ (2 * q.lenf) then
+ let (rf, rr) = split avg [] q.rear in
+ { face = q.face @ List.rev rr ; rear = List.rev rf; lenf = dif; lenr = avg }
+ else q
+
+let empty = {
+ face = [];
+ rear = [];
+ lenf = 0;
+ lenr = 0;
+}
+
+let lcons x q =
+ balance { q with lenf = succ q.lenf; face = x :: q.face }
+
+let lhd q = match q.face with
+| [] ->
+ begin match q.rear with
+ | [] -> raise Empty
+ | t :: _ -> t
+ end
+| t :: _ -> t
+
+let ltl q = match q.face with
+| [] ->
+ begin match q.rear with
+ | [] -> raise Empty
+ | t :: _ -> empty
+ end
+| t :: r -> balance { q with lenf = pred q.lenf; face = r }
+
+let rcons x q =
+ balance { q with lenr = succ q.lenr; rear = x :: q.rear }
+
+let rhd q = match q.rear with
+| [] ->
+ begin match q.face with
+ | [] -> raise Empty
+ | t :: r -> t
+ end
+| t :: _ -> t
+
+let rtl q = match q.rear with
+| [] ->
+ begin match q.face with
+ | [] -> raise Empty
+ | t :: r -> empty
+ end
+| t :: r ->
+ balance { q with lenr = pred q.lenr; rear = r }
+
+let rev q = {
+ face = q.rear;
+ rear = q.face;
+ lenf = q.lenr;
+ lenr = q.lenf;
+}
+
+let length q = q.lenf + q.lenr
+
+let is_empty q = Int.equal (length q) 0
+
+let filter f q =
+ let fold (accu, len) x = if f x then (x :: accu, succ len) else (accu, len) in
+ let (rf, lenf) = List.fold_left fold ([], 0) q.face in
+ let (rr, lenr) = List.fold_left fold ([], 0) q.rear in
+ balance { face = List.rev rf; rear = List.rev rr; lenf = lenf; lenr = lenr }
diff --git a/lib/deque.mli b/lib/deque.mli
new file mode 100644
index 00000000..fd644e3c
--- /dev/null
+++ b/lib/deque.mli
@@ -0,0 +1,58 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** * Purely functional, double-ended queues *)
+
+(** This module implements the banker's deque, from Okasaki. Most operations are
+ amortized O(1). *)
+
+type +'a t
+
+exception Empty
+
+(** {5 Constructor} *)
+
+val empty : 'a t
+
+(** The empty deque. *)
+
+(** {5 Left-side operations} *)
+
+val lcons : 'a -> 'a t -> 'a t
+(** Pushes an element on the left side of the deque. *)
+
+val lhd : 'a t -> 'a
+(** Returns the leftmost element in the deque. Raises [Empty] when empty. *)
+
+val ltl : 'a t -> 'a t
+(** Returns the left-tail of the deque. Raises [Empty] when empty. *)
+
+(** {5 Right-side operations} *)
+
+val rcons : 'a -> 'a t -> 'a t
+(** Same as [lcons] but on the right side. *)
+
+val rhd : 'a t -> 'a
+(** Same as [lhd] but on the right side. *)
+
+val rtl : 'a t -> 'a t
+(** Same as [ltl] but on the right side. *)
+
+(** {5 Operations} *)
+
+val rev : 'a t -> 'a t
+(** Reverse deque. *)
+
+val length : 'a t -> int
+(** Length of a deque. *)
+
+val is_empty : 'a t -> bool
+(** Emptyness of a deque. *)
+
+val filter : ('a -> bool) -> 'a t -> 'a t
+(** Filters the deque *)
diff --git a/lib/dnet.ml b/lib/dnet.ml
deleted file mode 100644
index 7f9bd949..00000000
--- a/lib/dnet.ml
+++ /dev/null
@@ -1,293 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* Generic dnet implementation over non-recursive types *)
-
-module type Datatype =
-sig
- type 'a t
- val map : ('a -> 'b) -> 'a t -> 'b t
- val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
- val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
- val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a
- val compare : unit t -> unit t -> int
- val terminal : 'a t -> bool
- val choose : ('a -> 'b) -> 'a t -> 'b
-end
-
-module type S =
-sig
- type t
- type ident
- type meta
- type 'a structure
- module Idset : Set.S with type elt=ident
- type 'a pattern =
- | Term of 'a
- | Meta of meta
- type term_pattern = ('a structure) pattern as 'a
- val empty : t
- val add : t -> term_pattern -> ident -> t
- val find_all : t -> Idset.t
- val fold_pattern :
- ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a
- val find_match : term_pattern -> t -> Idset.t
- val inter : t -> t -> t
- val union : t -> t -> t
- val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
-end
-
-module Make =
- functor (T:Datatype) ->
- functor (Ident:Set.OrderedType) ->
- functor (Meta:Set.OrderedType) ->
-struct
-
- type ident = Ident.t
- type meta = Meta.t
-
- type 'a pattern =
- | Term of 'a
- | Meta of meta
-
- type 'a structure = 'a T.t
-
- module Idset = Set.Make(Ident)
- module Mmap = Map.Make(Meta)
- module Tmap = Map.Make(struct type t = unit structure
- let compare = T.compare end)
-
- type term_pattern = term_pattern structure pattern
- type idset = Idset.t
-
-
-
- (* we store identifiers at the leaf of the dnet *)
- type node =
- | Node of t structure
- | Terminal of t structure * idset
-
- (* at each node, we have a bunch of nodes (actually a map between
- the bare node and a subnet) and a bunch of metavariables *)
- and t = Nodes of node Tmap.t * idset Mmap.t
-
- let empty : t = Nodes (Tmap.empty, Mmap.empty)
-
- (* the head of a data is of type unit structure *)
- let head w = T.map (fun c -> ()) w
-
- (* given a node of the net and a word, returns the subnet with the
- same head as the word (with the rest of the nodes) *)
- let split l (w:'a structure) : node * node Tmap.t =
- let elt : node = Tmap.find (head w) l in
- (elt, Tmap.remove (head w) l)
-
- let select l w = Tmap.find (head w) l
-
- let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t =
- match w with Term w ->
- ( try
- let (n,tl) = split t w in
- let new_node = match n with
- | Terminal (e,is) -> Terminal (e,Idset.add id is)
- | Node e -> Node (T.map2 (fun t p -> add t p id) e w) in
- Nodes ((Tmap.add (head w) new_node tl), m)
- with Not_found ->
- let new_content = T.map (fun p -> add empty p id) w in
- let new_node =
- if T.terminal w then
- Terminal (new_content, Idset.singleton id)
- else Node new_content in
- Nodes ((Tmap.add (head w) new_node t), m) )
- | Meta i ->
- let m =
- try Mmap.add i (Idset.add id (Mmap.find i m)) m
- with Not_found -> Mmap.add i (Idset.singleton id) m in
- Nodes (t, m)
-
- let add t w id = add t w id
-
- let rec find_all (Nodes (t,m)) : idset =
- Idset.union
- (Mmap.fold (fun _ -> Idset.union) m Idset.empty)
- (Tmap.fold
- ( fun _ n acc ->
- let s2 = match n with
- | Terminal (_,is) -> is
- | Node e -> T.choose find_all e in
- Idset.union acc s2
- ) t Idset.empty)
-
-(* (\* optimization hack: Not_found is catched in fold_pattern *\) *)
-(* let fast_inter s1 s2 = *)
-(* if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *)
-(* else Idset.inter s1 s2 *)
-
-(* let option_any2 f s1 s2 = match s1,s2 with *)
-(* | Some s1, Some s2 -> f s1 s2 *)
-(* | (Some s, _ | _, Some s) -> s *)
-(* | _ -> raise Not_found *)
-
-(* let fold_pattern ?(complete=true) f acc pat dn = *)
-(* let deferred = ref [] in *)
-(* let leafs,metas = ref None, ref None in *)
-(* let leaf s = leafs := match !leafs with *)
-(* | None -> Some s *)
-(* | Some s' -> Some (fast_inter s s') in *)
-(* let meta s = metas := match !metas with *)
-(* | None -> Some s *)
-(* | Some s' -> Some (Idset.union s s') in *)
-(* let defer c = deferred := c::!deferred in *)
-(* let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *)
-(* Mmap.iter (fun _ -> meta) m; (\* TODO: gérer patterns nonlin ici *\) *)
-(* match p with *)
-(* | Meta m -> defer (m,dn) *)
-(* | Term w -> *)
-(* try match select t w with *)
-(* | Terminal (_,is) -> leaf is *)
-(* | Node e -> *)
-(* if complete then T.fold2 (fun _ -> fp_rec) () w e else *)
-(* if T.fold2 *)
-(* (fun b p dn -> match p with *)
-(* | Term _ -> fp_rec p dn; false *)
-(* | Meta _ -> b *)
-(* ) true w e *)
-(* then T.choose (T.choose fp_rec w) e *)
-(* with Not_found -> *)
-(* if Mmap.is_empty m then raise Not_found else () *)
-(* in try *)
-(* fp_rec pat dn; *)
-(* (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *)
-(* List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *)
-(* with Not_found -> None,acc *)
-
- (* Sets with a neutral element for inter *)
- module OSet (S:Set.S) = struct
- type t = S.t option
- let union s1 s2 = match s1,s2 with
- | (None, _ | _, None) -> None
- | Some a, Some b -> Some (S.union a b)
- let inter s1 s2 = match s1,s2 with
- | (None, a | a, None) -> a
- | Some a, Some b -> Some (S.inter a b)
- let is_empty = function
- | None -> false
- | Some s -> S.is_empty s
- (* optimization hack: Not_found is catched in fold_pattern *)
- let fast_inter s1 s2 =
- if is_empty s1 || is_empty s2 then raise Not_found
- else let r = inter s1 s2 in
- if is_empty r then raise Not_found else r
- let full = None
- let empty = Some S.empty
- end
-
- module OIdset = OSet(Idset)
-
- let fold_pattern ?(complete=true) f acc pat dn =
- let deferred = ref [] in
- let defer c = deferred := c::!deferred in
-
- let rec fp_rec metas p (Nodes(t,m) as dn:t) =
- (* TODO gérer les dnets non-linéaires *)
- let metas = Mmap.fold (fun _ -> Idset.union) m metas in
- match p with
- | Meta m -> defer (metas,m,dn); OIdset.full
- | Term w ->
- let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in
- try match select t w with
- | Terminal (_,is) -> Some (Idset.union curm is)
- | Node e ->
- let ids = if complete then T.fold2
- (fun acc w e ->
- OIdset.fast_inter acc (fp_rec metas w e)
- ) OIdset.full w e
- else
- let (all_metas, res) = T.fold2
- (fun (b,acc) w e -> match w with
- | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e)
- | Meta _ -> b, acc
- ) (true,OIdset.full) w e in
- if all_metas then T.choose (T.choose (fp_rec metas) w) e
- else res in
- OIdset.union ids (Some curm)
- with Not_found ->
- if Idset.is_empty metas then raise Not_found else Some curm in
- let cand =
- try fp_rec Idset.empty pat dn
- with Not_found -> OIdset.empty in
- let res = List.fold_left f acc !deferred in
- cand, res
-
- (* intersection of two dnets. keep only the common pairs *)
- let rec inter (t1:t) (t2:t) : t =
- let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t =
- Nodes
- (Tmap.fold
- ( fun k e acc ->
- try Tmap.add k (f e (Tmap.find k t2)) acc
- with Not_found -> acc
- ) t1 Tmap.empty,
- Mmap.fold
- ( fun m s acc ->
- try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc
- with Not_found -> acc
- ) m1 Mmap.empty
- ) in
- inter_map
- (fun n1 n2 -> match n1,n2 with
- | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2)
- | Node e1, Node e2 -> Node (T.map2 inter e1 e2)
- | _ -> assert false
- ) t1 t2
-
- let rec union (t1:t) (t2:t) : t =
- let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t =
- Nodes
- (Tmap.fold
- ( fun k e acc ->
- try Tmap.add k (f e (Tmap.find k acc)) acc
- with Not_found -> Tmap.add k e acc
- ) t1 t2,
- Mmap.fold
- ( fun m s acc ->
- try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc
- with Not_found -> Mmap.add m s acc
- ) m1 m2
- ) in
- union_map
- (fun n1 n2 -> match n1,n2 with
- | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2)
- | Node e1, Node e2 -> Node (T.map2 union e1 e2)
- | _ -> assert false
- ) t1 t2
-
- let find_match (p:term_pattern) (t:t) : idset =
- let metas = ref Mmap.empty in
- let (mset,lset) = fold_pattern ~complete:false
- (fun acc (mset,m,t) ->
- let all = OIdset.fast_inter acc
- (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in
- metas := Mmap.add m t !metas;
- find_all t)) in
- OIdset.union (Some mset) all
- ) None p t in
- Option.get (OIdset.inter mset lset)
-
- let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn
-
- let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty
- let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty
-
- let rec map sidset sterm (Nodes (t,m)) : t =
- let snode = function
- | Terminal (e,is) -> Terminal (e,idset_map sidset is)
- | Node e -> Node (T.map (map sidset sterm) e) in
- Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m)
-
-end
diff --git a/lib/dnet.mli b/lib/dnet.mli
deleted file mode 100644
index 826e120a..00000000
--- a/lib/dnet.mli
+++ /dev/null
@@ -1,126 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** Generic discrimination net implementation over recursive
- types. This module implements a association data structure similar
- to tries but working on any types (not just lists). It is a term
- indexing datastructure, a generalization of the discrimination nets
- described for example in W.W.McCune, 1992, related also to
- generalized tries [Hinze, 2000].
-
- You can add pairs of (term,identifier) into a dnet, where the
- identifier is *unique*, and search terms in a dnet filtering a
- given pattern (retrievial of instances). It returns all identifiers
- associated with terms matching the pattern. It also works the other
- way around : You provide a set of patterns and a term, and it
- returns all patterns which the term matches (retrievial of
- generalizations). That's why you provide *patterns* everywhere.
-
- Warning 1: Full unification doesn't work as for now. Make sure the
- set of metavariables in the structure and in the queries are
- distincts, or you'll get unexpected behaviours.
-
- Warning 2: This structure is perfect, i.e. the set of candidates
- returned is equal to the set of solutions. Beware of DeBruijn
- shifts and sorts subtyping though (which makes the comparison not
- symmetric, see term_dnet.ml).
-
- The complexity of the search is (almost) the depth of the term.
-
- To use it, you have to provide a module (Datatype) with the datatype
- parametrized on the recursive argument. example:
-
- type btree = type 'a btree0 =
- | Leaf ===> | Leaf
- | Node of btree * btree | Node of 'a * 'a
-
-*)
-
-(** datatype you want to build a dnet on *)
-module type Datatype =
-sig
- (** parametric datatype. ['a] is morally the recursive argument *)
- type 'a t
-
- (** non-recursive mapping of subterms *)
- val map : ('a -> 'b) -> 'a t -> 'b t
- val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
-
- (** non-recursive folding of subterms *)
- val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
- val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a
-
- (** comparison of constructors *)
- val compare : unit t -> unit t -> int
-
- (** for each constructor, is it not-parametric on 'a? *)
- val terminal : 'a t -> bool
-
- (** [choose f w] applies f on ONE of the subterms of w *)
- val choose : ('a -> 'b) -> 'a t -> 'b
-end
-
-module type S =
-sig
- type t
-
- (** provided identifier type *)
- type ident
-
- (** provided metavariable type *)
- type meta
-
- (** provided parametrized datastructure *)
- type 'a structure
-
- (** returned sets of solutions *)
- module Idset : Set.S with type elt=ident
-
- (** a pattern is a term where each node can be a unification
- variable *)
- type 'a pattern =
- | Term of 'a
- | Meta of meta
-
- type term_pattern = 'a structure pattern as 'a
-
- val empty : t
-
- (** [add t w i] adds a new association (w,i) in t. *)
- val add : t -> term_pattern -> ident -> t
-
- (** [find_all t] returns all identifiers contained in t. *)
- val find_all : t -> Idset.t
-
- (** [fold_pattern f acc p dn] folds f on each meta of p, passing the
- meta and the sub-dnet under it. The result includes:
- - Some set if identifiers were gathered on the leafs of the term
- - None if the pattern contains no leaf (only Metas at the leafs).
- *)
- val fold_pattern :
- ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a
-
- (** [find_match p t] returns identifiers of all terms matching p in
- t. *)
- val find_match : term_pattern -> t -> Idset.t
-
- (** set operations on dnets *)
- val inter : t -> t -> t
- val union : t -> t -> t
-
- (** apply a function on each identifier and node of terms in a dnet *)
- val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t
-end
-
-module Make :
- functor (T:Datatype) ->
- functor (Ident:Set.OrderedType) ->
- functor (Meta:Set.OrderedType) ->
- S with type ident = Ident.t
- and type meta = Meta.t
- and type 'a structure = 'a T.t
diff --git a/lib/dyn.ml b/lib/dyn.ml
index e756297f..63def9a1 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -1,25 +1,49 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Util
+open Errors
(* Dynamics, programmed with DANGER !!! *)
-type t = string * Obj.t
+type t = int * Obj.t
-let dyntab = ref ([] : string list)
+let dyntab = ref (Int.Map.empty : string Int.Map.t)
+(** Instead of working with tags as strings, which are costly, we use their
+ hash. We ensure unicity of the hash in the [create] function. If ever a
+ collision occurs, which is unlikely, it is sufficient to tweak the offending
+ dynamic tag. *)
-let create s =
- if List.mem s !dyntab then
- anomaly ("Dyn.create: already declared dynamic " ^ s);
- dyntab := s :: !dyntab;
- ((fun v -> (s,Obj.repr v)),
- (fun (s',rv) ->
- if s = s' then Obj.magic rv else failwith "dyn_out"))
+let create (s : string) =
+ let hash = Hashtbl.hash s in
+ let () =
+ if Int.Map.mem hash !dyntab then
+ let old = Int.Map.find hash !dyntab in
+ let msg = Pp.str ("Dynamic tag collision: " ^ s ^ " vs. " ^ old) in
+ anomaly ~label:"Dyn.create" msg
+ in
+ let () = dyntab := Int.Map.add hash s !dyntab in
+ let infun v = (hash, Obj.repr v) in
+ let outfun (nh, rv) =
+ if Int.equal hash nh then Obj.magic rv
+ else
+ let msg = (Pp.str ("dyn_out: expected " ^ s)) in
+ anomaly msg
+ in
+ (infun, outfun)
-let tag (s,_) = s
+let has_tag (s, _) tag =
+ let hash = Hashtbl.hash (tag : string) in
+ Int.equal s hash
+
+let tag (s,_) =
+ try Int.Map.find s !dyntab
+ with Not_found ->
+ let msg = Pp.str ("Unknown dynamic tag " ^ (string_of_int s)) in
+ anomaly msg
+
+let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2
diff --git a/lib/dyn.mli b/lib/dyn.mli
index 3ddde2b6..4a713472 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -12,3 +12,5 @@ type t
val create : string -> ('a -> t) * (t -> 'a)
val tag : t -> string
+val has_tag : t -> string -> bool
+val pointer_equal : t -> t -> bool
diff --git a/lib/envars.ml b/lib/envars.ml
index 3040dd41..b0eed838 100644
--- a/lib/envars.ml
+++ b/lib/envars.ml
@@ -1,130 +1,219 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* This file gathers environment variables needed by Coq to run (such
- as coqlib) *)
+open Util
-let (//) s1 s2 = s1 ^ "/" ^ s2
+(** {1 Helper functions} *)
-let coqbin =
- System.canonical_path_name (Filename.dirname Sys.executable_name)
+let getenv_else s dft = try Sys.getenv s with Not_found -> dft ()
-(* The following only makes sense when executables are running from
- source tree (e.g. during build or in local mode). *)
-let coqroot = Filename.dirname coqbin
+let safe_getenv warning n =
+ getenv_else n (fun () ->
+ warning ("Environment variable "^n^" not found: using '$"^n^"' .");
+ ("$"^n)
+ )
-(* On win32, we add coqbin to the PATH at launch-time (this used to be
- done in a .bat script). *)
+let ( / ) a b =
+ if Filename.is_relative b then a ^ "/" ^ b else b
-let _ =
- if Coq_config.arch = "win32" then
- Unix.putenv "PATH" (coqbin ^ ";" ^ System.getenv_else "PATH" "")
+let coqify d = d / "coq"
-let exe s = s ^ Coq_config.exec_extension
+let opt2list = function None -> [] | Some x -> [x]
-let reldir instdir testfile oth =
- let rpath = if Coq_config.local then [] else instdir in
- let out = List.fold_left (//) coqroot rpath in
- if Sys.file_exists (out//testfile) then out else oth ()
-
-let guess_coqlib () =
- let file = "states/initial.coq" in
- reldir (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) file
- (fun () ->
- let coqlib = match Coq_config.coqlib with
- | Some coqlib -> coqlib
- | None -> coqroot
- in
- if Sys.file_exists (coqlib//file)
- then coqlib
- else Util.error "cannot guess a path for Coq libraries; please use -coqlib option")
-
-let coqlib () =
- if !Flags.coqlib_spec then !Flags.coqlib else
- (if !Flags.boot then coqroot else guess_coqlib ())
-
-let docdir () =
- reldir (if Coq_config.arch = "win32" then ["doc"] else ["share";"doc";"coq"]) "html" (fun () -> Coq_config.docdir)
+let home ~warn =
+ getenv_else "HOME" (fun () ->
+ try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
+ getenv_else "USERPROFILE" (fun () ->
+ warn ("Cannot determine user home directory, using '.' .");
+ Filename.current_dir_name))
let path_to_list p =
- let sep = if Sys.os_type = "Win32" then ';' else ':' in
- Util.split_string_at sep p
+ let sep = if String.equal Sys.os_type "Win32" then ';' else ':' in
+ String.split sep p
+
+let user_path () =
+ path_to_list (Sys.getenv "PATH") (* may raise Not_found *)
+
+let rec which l f =
+ match l with
+ | [] ->
+ raise Not_found
+ | p :: tl ->
+ if Sys.file_exists (p / f) then
+ p
+ else
+ which tl f
+
+let expand_path_macros ~warn s =
+ let rec expand_atom s i =
+ let l = String.length s in
+ if i<l && (Util.is_digit s.[i] || Util.is_letter s.[i] || s.[i] == '_')
+ then expand_atom s (i+1)
+ else i in
+ let rec expand_macros s i =
+ let l = String.length s in
+ if Int.equal i l then s else
+ match s.[i] with
+ | '$' ->
+ let n = expand_atom s (i+1) in
+ let v = safe_getenv warn (String.sub s (i+1) (n-i-1)) in
+ let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in
+ expand_macros s (i + String.length v)
+ | '~' when Int.equal i 0 ->
+ let n = expand_atom s (i+1) in
+ let v =
+ if Int.equal n (i + 1) then home ~warn
+ else (Unix.getpwnam (String.sub s (i+1) (n-i-1))).Unix.pw_dir
+ in
+ let s = v^(String.sub s n (l-n)) in
+ expand_macros s (String.length v)
+ | c -> expand_macros s (i+1)
+ in expand_macros s 0
+
+(** {1 Paths} *)
+
+(** {2 Coq paths} *)
+
+let relative_base =
+ Filename.dirname (Filename.dirname Sys.executable_name)
-let xdg_data_home =
- (System.getenv_else "XDG_DATA_HOME" (System.home//".local/share"))//"coq"
+let coqbin =
+ CUnix.canonical_path_name (Filename.dirname Sys.executable_name)
-let xdg_config_home =
- (System.getenv_else "XDG_CONFIG_HOME" (System.home//".config"))//"coq"
+(** The following only makes sense when executables are running from
+ source tree (e.g. during build or in local mode). *)
+let coqroot =
+ Filename.dirname coqbin
-let xdg_data_dirs =
- (try
- List.map (fun dir -> dir//"coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
- with Not_found -> ["/usr/local/share/coq";"/usr/share/coq"])
- @ (match Coq_config.datadir with |None -> [] |Some datadir -> [datadir])
+(** On win32, we add coqbin to the PATH at launch-time (this used to be
+ done in a .bat script). *)
+let _ =
+ if Coq_config.arch_is_win32 then
+ Unix.putenv "PATH" (coqbin ^ ";" ^ getenv_else "PATH" (fun () -> ""))
+
+(** [check_file_else ~dir ~file oth] checks if [file] exists in
+ the installation directory [dir] given relatively to [coqroot].
+ If this Coq is only locally built, then [file] must be in [coqroot].
+ If the check fails, then [oth ()] is evaluated. *)
+let check_file_else ~dir ~file oth =
+ let path = if Coq_config.local then coqroot else coqroot / dir in
+ if Sys.file_exists (path / file) then path else oth ()
+
+let guess_coqlib fail =
+ let prelude = "theories/Init/Prelude.vo" in
+ let dir = if Coq_config.arch_is_win32 then "lib" else "lib/coq" in
+ check_file_else ~dir ~file:prelude
+ (fun () ->
+ let coqlib = match Coq_config.coqlib with
+ | Some coqlib -> coqlib
+ | None -> coqroot
+ in
+ if Sys.file_exists (coqlib / prelude) then coqlib
+ else
+ fail "cannot guess a path for Coq libraries; please use -coqlib option")
+
+(** coqlib is now computed once during coqtop initialization *)
+
+let set_coqlib ~fail =
+ if not !Flags.coqlib_spec then
+ let lib = if !Flags.boot then coqroot else guess_coqlib fail in
+ Flags.coqlib := lib
+
+let coqlib () = !Flags.coqlib
-let xdg_dirs =
- let dirs = xdg_data_home :: xdg_data_dirs
- in
- List.rev (List.filter Sys.file_exists dirs)
+let docdir () =
+ let dir = if Coq_config.arch_is_win32 then "doc" else "share/doc/coq" in
+ check_file_else ~dir ~file:"html" (fun () -> Coq_config.docdir)
let coqpath =
- try
- let path = Sys.getenv "COQPATH" in
- List.rev (List.filter Sys.file_exists (path_to_list path))
- with Not_found -> []
+ let coqpath = getenv_else "COQPATH" (fun () -> "") in
+ let make_search_path path =
+ let paths = path_to_list path in
+ let valid_paths = List.filter Sys.file_exists paths in
+ List.rev valid_paths
+ in
+ make_search_path coqpath
-let rec which l f =
- match l with
- | [] -> raise Not_found
- | p :: tl ->
- if Sys.file_exists (p//f)
- then p
- else which tl f
+(** {2 Caml paths} *)
-let guess_camlbin () =
- let path = Sys.getenv "PATH" in (* may raise Not_found *)
- let lpath = path_to_list path in
- which lpath (exe "ocamlc")
+let exe s = s ^ Coq_config.exec_extension
-let guess_camlp4bin () =
- let path = Sys.getenv "PATH" in (* may raise Not_found *)
- let lpath = path_to_list path in
- which lpath (exe Coq_config.camlp4)
+let guess_camlbin () = which (user_path ()) (exe "ocamlc")
let camlbin () =
if !Flags.camlbin_spec then !Flags.camlbin else
if !Flags.boot then Coq_config.camlbin else
- try guess_camlbin () with e when e <> Sys.Break -> Coq_config.camlbin
+ try guess_camlbin () with Not_found -> Coq_config.camlbin
+
+let ocamlc () = camlbin () / Coq_config.ocamlc
+
+let ocamlopt () = camlbin () / Coq_config.ocamlopt
let camllib () =
- if !Flags.boot
- then Coq_config.camllib
+ if !Flags.boot then
+ Coq_config.camllib
else
- let camlbin = camlbin () in
- let com = (camlbin//"ocamlc") ^ " -where" in
- let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in
- Util.strip res
+ let _, res = CUnix.run_command (ocamlc () ^ " -where") in
+ String.strip res
+
+(** {2 Camlp4 paths} *)
+
+let guess_camlp4bin () = which (user_path ()) (exe Coq_config.camlp4)
let camlp4bin () =
if !Flags.camlp4bin_spec then !Flags.camlp4bin else
if !Flags.boot then Coq_config.camlp4bin else
- try guess_camlp4bin () with e when e <> Sys.Break ->
+ try guess_camlp4bin ()
+ with Not_found ->
let cb = camlbin () in
- if Sys.file_exists (cb//(exe Coq_config.camlp4)) then cb
- else Coq_config.camlp4bin
+ if Sys.file_exists (cb / exe Coq_config.camlp4) then cb
+ else Coq_config.camlp4bin
+
+let camlp4 () = camlp4bin () / exe Coq_config.camlp4
let camlp4lib () =
- if !Flags.boot
- then Coq_config.camlp4lib
+ if !Flags.boot then
+ Coq_config.camlp4lib
else
- let camlp4bin = camlp4bin () in
- let com = (camlp4bin//Coq_config.camlp4) ^ " -where" in
- let ex,res = System.run_command (fun x -> x) (fun _ -> ()) com in
+ let ex, res = CUnix.run_command (camlp4 () ^ " -where") in
match ex with
- |Unix.WEXITED 0 -> Util.strip res
- |_ -> "/dev/null"
+ | Unix.WEXITED 0 -> String.strip res
+ | _ -> "/dev/null"
+
+(** {1 XDG utilities} *)
+
+let xdg_data_home warn =
+ coqify
+ (getenv_else "XDG_DATA_HOME" (fun () -> (home ~warn) / ".local/share"))
+
+let xdg_config_home warn =
+ coqify
+ (getenv_else "XDG_CONFIG_HOME" (fun () -> (home ~warn) / ".config"))
+
+let xdg_data_dirs warn =
+ let sys_dirs =
+ try
+ List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
+ with
+ | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "share"]
+ | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]
+ in
+ xdg_data_home warn :: sys_dirs @ opt2list Coq_config.datadir
+
+let xdg_config_dirs warn =
+ let sys_dirs =
+ try
+ List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
+ with
+ | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "config"]
+ | Not_found -> ["/etc/xdg/coq"]
+ in
+ xdg_config_home warn :: sys_dirs @ opt2list Coq_config.configdir
+
+let xdg_dirs ~warn =
+ List.filter Sys.file_exists (xdg_data_dirs warn)
diff --git a/lib/envars.mli b/lib/envars.mli
index 023b54c0..b62b9f28 100644
--- a/lib/envars.mli
+++ b/lib/envars.mli
@@ -1,25 +1,80 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(** This file gathers environment variables needed by Coq to run (such
- as coqlib) *)
+(** This file provides a high-level interface to the environment variables
+ needed by Coq to run (such as coqlib). The values of these variables
+ may come from different sources (shell environment variables,
+ command line options, options set at the time Coq was build). *)
+(** [expand_path_macros warn s] substitutes environment variables
+ in a string by their values. This function also takes care of
+ substituting path of the form '~X' by an absolute path.
+ Use [warn] as a message displayer. *)
+val expand_path_macros : warn:(string -> unit) -> string -> string
+
+(** [home warn] returns the root of the user directory, depending
+ on the OS. This information is usually stored in the $HOME
+ environment variable on POSIX shells. If no such variable
+ exists, then other common names are tried (HOMEDRIVE, HOMEPATH,
+ USERPROFILE). If all of them fail, [warn] is called. *)
+val home : warn:(string -> unit) -> string
+
+(** [coqlib] is the path to the Coq library. *)
val coqlib : unit -> string
+
+(** [set_coqlib] must be runned once before any access to [coqlib] *)
+val set_coqlib : fail:(string -> string) -> unit
+
+(** [docdir] is the path to the Coq documentation. *)
val docdir : unit -> string
+
+(** [coqbin] is the name of the current executable. *)
val coqbin : string
+
+(** [coqroot] is the path to [coqbin].
+ The following value only makes sense when executables are running from
+ source tree (e.g. during build or in local mode).
+*)
val coqroot : string
-(* coqpath is stored in reverse order, since that is the order it
- * gets added to the searc path *)
-val xdg_config_home : string
-val xdg_dirs : string list
+
+(** [coqpath] is the standard path to coq.
+ Notice that coqpath is stored in reverse order, since that is
+ the order it gets added to the search path. *)
val coqpath : string list
+(** [camlbin ()] is the path to the ocaml binaries. *)
val camlbin : unit -> string
-val camlp4bin : unit -> string
+
+(** [camllib ()] is the path to the ocaml standard library. *)
val camllib : unit -> string
+
+(** [ocamlc ()] is the ocaml bytecode compiler that compiled this Coq. *)
+val ocamlc : unit -> string
+
+(** [ocamlc ()] is the ocaml native compiler that compiled this Coq. *)
+val ocamlopt : unit -> string
+
+(** [camlp4bin ()] is the path to the camlp4 binary. *)
+val camlp4bin : unit -> string
+
+(** [camlp4lib ()] is the path to the camlp4 library. *)
val camlp4lib : unit -> string
+
+(** [camlp4 ()] is the camlp4 utility. *)
+val camlp4 : unit -> string
+
+(** Coq tries to honor the XDG Base Directory Specification to access
+ the user's configuration files.
+
+ see [http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html]
+*)
+val xdg_config_home : (string -> unit) -> string
+val xdg_data_home : (string -> unit) -> string
+val xdg_config_dirs : (string -> unit) -> string list
+val xdg_data_dirs : (string -> unit) -> string list
+val xdg_dirs : warn : (string -> unit) -> string list
diff --git a/lib/ephemeron.ml b/lib/ephemeron.ml
new file mode 100644
index 00000000..b36904ca
--- /dev/null
+++ b/lib/ephemeron.ml
@@ -0,0 +1,89 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type key_type = int
+
+type boxed_key = key_type ref ref
+
+let mk_key : unit -> boxed_key =
+ (* TODO: take a random value here. Is there a random function in OCaml? *)
+ let bid = ref 0 in
+ (* According to OCaml Gc module documentation, Pervasives.ref is one of the
+ few ways of getting a boxed value the compiler will never alias. *)
+ fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid)
+
+(* A phantom type to preserve type safety *)
+type 'a key = boxed_key
+
+(* Comparing keys with == grants that if a key is unmarshalled (in the same
+ process where it was created or in another one) it is not mistaken for
+ an already existing one (unmarshal has no right to alias). If the initial
+ value of bid is taken at random, then one also avoids potential collisions *)
+module HT = Hashtbl.Make(struct
+ type t = key_type ref
+ let equal k1 k2 = k1 == k2
+ let hash id = !id
+end)
+
+(* A key is the (unique) value inside a boxed key, hence it does not
+ keep its corresponding boxed key reachable (replacing key_type by boxed_key
+ would make the key always reachable) *)
+let values : Obj.t HT.t = HT.create 1001
+
+(* To avoid a race contidion between the finalization function and
+ get/create on the values hashtable, the finalization function just
+ enqueues in an imperative list the item to be collected. Being the list
+ imperative, even if the Gc enqueue an item while run_collection is operating,
+ the tail of the list is eventually set to Empty on completion.
+ Kudos to the authors of Why3 that came up with this solution for their
+ implementation of weak hash tables! *)
+type imperative_list = cell ref
+and cell = Empty | Item of key_type ref * imperative_list
+
+let collection_queue : imperative_list ref = ref (ref Empty)
+
+let enqueue x = collection_queue := ref (Item (!x, !collection_queue))
+
+let run_collection () =
+ let rec aux l = match !l with
+ | Empty -> ()
+ | Item (k, tl) -> HT.remove values k; aux tl in
+ let l = !collection_queue in
+ aux l;
+ l := Empty
+
+(* The only reference to the boxed key is the one returned, when the user drops
+ it the value eventually disappears from the values table above *)
+let create (v : 'a) : 'a key =
+ run_collection ();
+ let k = mk_key () in
+ HT.add values !k (Obj.repr v);
+ Gc.finalise enqueue k;
+ k
+
+(* Avoid raising Not_found *)
+exception InvalidKey
+let get (k : 'a key) : 'a =
+ run_collection ();
+ try Obj.obj (HT.find values !k)
+ with Not_found -> raise InvalidKey
+
+(* Simple utils *)
+let default k v =
+ try get k
+ with InvalidKey -> v
+
+let iter_opt k f =
+ match
+ try Some (get k)
+ with InvalidKey -> None
+ with
+ | None -> ()
+ | Some v -> f v
+
+let clear () = run_collection ()
diff --git a/lib/ephemeron.mli b/lib/ephemeron.mli
new file mode 100644
index 00000000..195b23db
--- /dev/null
+++ b/lib/ephemeron.mli
@@ -0,0 +1,52 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Use case:
+ You have a data structure that needs to be marshalled but it contains
+ unmarshallable data (like a closure, or a file descriptor). Actually
+ you don't need this data to be preserved by marshalling, it just happens
+ to be there.
+ You could produced a trimmed down data structure, but then, once
+ unmarshalled, you can't used the very same code to process it, unless you
+ re-inject the trimmed down data structure into the standard one, using
+ dummy values for the unmarshallable stuff.
+ Similarly you could change your data structure turning all types [bad]
+ into [bad option], then just before marshalling you set all values of type
+ [bad option] to [None]. Still this pruning may be expensive and you have
+ to code it.
+
+ Desiderata:
+ The marshalling operation automatically discards values that cannot be
+ marshalled or cannot be properly unmarshalled.
+
+ Proposed solution:
+ Turn all occurrences of [bad] into [bad key] in your data structure.
+ Use [crate bad_val] to obtain a unique key [k] for [bad_val], and store
+ [k] in the data structure. Use [get k] to obtain [bad_val].
+
+ An ['a key] can always be marshalled. When marshalled, a key loses its
+ value. The function [get] raises Not_found on unmarshalled keys.
+
+ If a key is garbage collected, the corresponding value is garbage
+ collected too (unless extra references to it exist).
+ In short no memory management hassle, keys can just replace their
+ corresponding value in the data structure. *)
+
+type 'a key
+
+val create : 'a -> 'a key
+
+(* May raise InvalidKey *)
+exception InvalidKey
+val get : 'a key -> 'a
+
+(* These never fail. *)
+val iter_opt : 'a key -> ('a -> unit) -> unit
+val default : 'a key -> 'a -> 'a
+
+val clear : unit -> unit
diff --git a/lib/errors.ml b/lib/errors.ml
index 6affea23..ab331d6a 100644
--- a/lib/errors.ml
+++ b/lib/errors.ml
@@ -8,8 +8,40 @@
open Pp
-(* spiwack: it might be reasonable to decide and move the declarations
- of Anomaly and so on to this module so as not to depend on Util. *)
+(** Aliases *)
+
+let push = Backtrace.add_backtrace
+
+(* Errors *)
+
+exception Anomaly of string option * std_ppcmds (* System errors *)
+
+let make_anomaly ?label pp =
+ Anomaly (label, pp)
+
+let anomaly ?loc ?label pp = match loc with
+ | None -> raise (Anomaly (label, pp))
+ | Some loc -> Loc.raise loc (Anomaly (label, pp))
+
+let is_anomaly = function
+| Anomaly _ -> true
+| _ -> false
+
+exception UserError of string * std_ppcmds (* User errors *)
+let error string = raise (UserError("_", str string))
+let errorlabstrm l pps = raise (UserError(l,pps))
+
+exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
+let alreadydeclared pps = raise (AlreadyDeclared(pps))
+
+let todo s = prerr_string ("TODO: "^s^"\n")
+
+let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm))
+let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s)
+
+exception Timeout
+exception Drop
+exception Quit
let handle_stack = ref []
@@ -34,14 +66,24 @@ let rec print_gen bottom stk e =
In usual situation, the [handle_stack] is treated as it if was always
non-empty with [print_anomaly] as its bottom handler. *)
-let where s =
+let where = function
+| None -> mt ()
+| Some s ->
if !Flags.debug then str ("in "^s^":") ++ spc () else mt ()
let raw_anomaly e = match e with
- | Util.Anomaly (s,pps) -> where s ++ pps ++ str "."
+ | Anomaly (s, pps) -> where s ++ pps ++ str "."
| Assert_failure _ | Match_failure _ -> str (Printexc.to_string e ^ ".")
| _ -> str ("Uncaught exception " ^ Printexc.to_string e ^ ".")
+let print_backtrace e = match Backtrace.get_backtrace e with
+| None -> mt ()
+| Some bt ->
+ let bt = Backtrace.repr bt in
+ let pr_frame f = str (Backtrace.print_frame f) in
+ let bt = prlist_with_sep fnl pr_frame bt in
+ fnl () ++ hov 0 bt
+
let print_anomaly askreport e =
if askreport then
hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ str "Please report.")
@@ -49,20 +91,20 @@ let print_anomaly askreport e =
hov 0 (raw_anomaly e)
(** The standard exception printer *)
-let print e = print_gen (print_anomaly true) !handle_stack e
+let print ?(info = Exninfo.null) e =
+ print_gen (print_anomaly true) !handle_stack e ++ print_backtrace info
+
+let iprint (e, info) = print ~info e
(** Same as [print], except that the "Please report" part of an anomaly
isn't printed (used in Ltac debugging). *)
let print_no_report e = print_gen (print_anomaly false) !handle_stack e
-(** Same as [print], except that anomalies are not printed but re-raised
- (used for the Fail command) *)
-let print_no_anomaly e = print_gen (fun e -> raise e) !handle_stack e
-
(** Predefined handlers **)
let _ = register_handler begin function
- | Util.UserError(s,pps) -> hov 0 (str "Error: " ++ where s ++ pps)
+ | UserError(s, pps) ->
+ hov 0 (str "Error: " ++ where (Some s) ++ pps)
| _ -> raise Unhandled
end
@@ -70,10 +112,9 @@ end
by inner functions during a [vernacinterp]. They should be handled
only at the very end of interp, to be displayed to the user. *)
-(** NB: in the 8.4 branch, for maximal compatibility, anomalies
- are considered non-critical *)
-
let noncritical = function
- | Sys.Break | Out_of_memory | Stack_overflow -> false
+ | Sys.Break | Out_of_memory | Stack_overflow
+ | Assert_failure _ | Match_failure _ | Anomaly _
+ | Timeout | Drop | Quit -> false
+ | Invalid_argument "equal: functional value" -> false
| _ -> true
-
diff --git a/lib/errors.mli b/lib/errors.mli
index ae4d0b85..e4096a7e 100644
--- a/lib/errors.mli
+++ b/lib/errors.mli
@@ -6,9 +6,53 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
+open Pp
+
(** This modules implements basic manipulations of errors for use
throughout Coq's code. *)
+(** {6 Error handling} *)
+
+val push : exn -> Exninfo.iexn
+(** Alias for [Backtrace.add_backtrace]. *)
+
+(** {6 Generic errors.}
+
+ [Anomaly] is used for system errors and [UserError] for the
+ user's ones. *)
+
+val make_anomaly : ?label:string -> std_ppcmds -> exn
+(** Create an anomaly. *)
+
+val anomaly : ?loc:Loc.t -> ?label:string -> std_ppcmds -> 'a
+(** Raise an anomaly, with an optional location and an optional
+ label identifying the anomaly. *)
+
+val is_anomaly : exn -> bool
+(** Check whether a given exception is an anomaly.
+ This is mostly provided for compatibility. Please avoid doing specific
+ tricks with anomalies thanks to it. See rather [noncritical] below. *)
+
+exception UserError of string * std_ppcmds
+val error : string -> 'a
+val errorlabstrm : string -> std_ppcmds -> 'a
+val user_err_loc : Loc.t * string * std_ppcmds -> 'a
+
+exception AlreadyDeclared of std_ppcmds
+val alreadydeclared : std_ppcmds -> 'a
+
+val invalid_arg_loc : Loc.t * string -> 'a
+
+(** [todo] is for running of an incomplete code its implementation is
+ "do nothing" (or print a message), but this function should not be
+ used in a released code *)
+
+val todo : string -> unit
+
+exception Timeout
+exception Drop
+exception Quit
+
(** [register_handler h] registers [h] as a handler.
When an expression is printed with [print e], it
goes through all registered handles (the most
@@ -30,20 +74,16 @@ exception Unhandled
val register_handler : (exn -> Pp.std_ppcmds) -> unit
(** The standard exception printer *)
-val print : exn -> Pp.std_ppcmds
+val print : ?info:Exninfo.info -> exn -> Pp.std_ppcmds
+val iprint : Exninfo.iexn -> Pp.std_ppcmds
(** Same as [print], except that the "Please report" part of an anomaly
isn't printed (used in Ltac debugging). *)
val print_no_report : exn -> Pp.std_ppcmds
-(** Same as [print], except that anomalies are not printed but re-raised
- (used for the Fail command) *)
-val print_no_anomaly : exn -> Pp.std_ppcmds
-
(** Critical exceptions shouldn't be catched and ignored by mistake
by inner functions during a [vernacinterp]. They should be handled
only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user.
- Typical example: [Sys.Break]. In the 8.4 branch, for maximal
- compatibility, anomalies are not considered as critical...
+ Typical example: [Sys.Break], [Assert_failure], [Anomaly] ...
*)
val noncritical : exn -> bool
diff --git a/lib/exninfo.ml b/lib/exninfo.ml
new file mode 100644
index 00000000..d049dc6c
--- /dev/null
+++ b/lib/exninfo.ml
@@ -0,0 +1,104 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** Enriched exceptions have an additional field at the end of their usual data
+ containing a pair composed of the distinguishing [token] and the backtrace
+ information. We discriminate the token by pointer equality. *)
+
+module Store = Store.Make(struct end)
+
+type 'a t = 'a Store.field
+
+type info = Store.t
+
+type iexn = exn * info
+
+let make = Store.field
+let add = Store.set
+let get = Store.get
+let null = Store.empty
+
+exception Unique
+
+let dummy = (Unique, Store.empty)
+
+let current : (int * iexn) list ref = ref []
+(** List associating to each thread id the latest exception raised by an
+ instrumented raise (i.e. {!raise} from this module). It is shared between
+ threads, so we must take care of this when modifying it.
+
+ Invariants: all index keys are unique in the list.
+*)
+
+let lock = Mutex.create ()
+
+let rec remove_assoc (i : int) = function
+| [] -> []
+| (j, v) :: rem as l ->
+ if i = j then rem
+ else
+ let ans = remove_assoc i rem in
+ if rem == ans then l
+ else (j, v) :: ans
+
+let rec find_and_remove_assoc (i : int) = function
+| [] -> dummy, []
+| (j, v) :: rem as l ->
+ if i = j then (v, rem)
+ else
+ let (r, ans) = find_and_remove_assoc i rem in
+ if rem == ans then (r, l)
+ else (r, (j, v) :: ans)
+
+let iraise e =
+ let () = Mutex.lock lock in
+ let id = Thread.id (Thread.self ()) in
+ let () = current := (id, e) :: remove_assoc id !current in
+ let () = Mutex.unlock lock in
+ raise (fst e)
+
+let raise ?info e = match info with
+| None ->
+ let () = Mutex.lock lock in
+ let id = Thread.id (Thread.self ()) in
+ let () = current := remove_assoc id !current in
+ let () = Mutex.unlock lock in
+ raise e
+| Some i ->
+ let () = Mutex.lock lock in
+ let id = Thread.id (Thread.self ()) in
+ let () = current := (id, (e, i)) :: remove_assoc id !current in
+ let () = Mutex.unlock lock in
+ raise e
+
+let find_and_remove () =
+ let () = Mutex.lock lock in
+ let id = Thread.id (Thread.self ()) in
+ let (v, l) = find_and_remove_assoc id !current in
+ let () = current := l in
+ let () = Mutex.unlock lock in
+ v
+
+let info e =
+ let (src, data) = find_and_remove () in
+ if src == e then
+ (** Slightly unsound, some exceptions may not be unique up to pointer
+ equality. Though, it should be quite exceptional to be in a situation
+ where the following holds:
+
+ 1. An argument-free exception is raised through the enriched {!raise};
+ 2. It is not captured by any enriched with-clause (which would reset
+ the current data);
+ 3. The same exception is raised through the standard raise, accessing
+ the wrong data.
+ . *)
+ data
+ else
+ (** Mismatch: the raised exception is not the one stored, either because the
+ previous raise was not instrumented, or because something went wrong. *)
+ Store.empty
diff --git a/lib/exninfo.mli b/lib/exninfo.mli
new file mode 100644
index 00000000..c960ac7c
--- /dev/null
+++ b/lib/exninfo.mli
@@ -0,0 +1,39 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** Additional information worn by exceptions. *)
+
+type 'a t
+(** Information containing a given type. *)
+
+type info
+(** All information *)
+
+type iexn = exn * info
+(** Information-wearing exceptions *)
+
+val make : unit -> 'a t
+(** Create a new piece of information. *)
+
+val null : info
+(** No information *)
+
+val add : info -> 'a t -> 'a -> info
+(** Add information to an exception. *)
+
+val get : info -> 'a t -> 'a option
+(** Get information worn by an exception. Returns [None] if undefined. *)
+
+val info : exn -> info
+(** Retrieve the information of the last exception raised. *)
+
+val iraise : iexn -> 'a
+(** Raise the given enriched exception. *)
+
+val raise : ?info:info -> exn -> 'a
+(** Raise the given exception with additional information. *)
diff --git a/lib/explore.ml b/lib/explore.ml
index 31a96774..3d57fc08 100644
--- a/lib/explore.ml
+++ b/lib/explore.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -21,7 +21,7 @@ module Make = functor(S : SearchProblem) -> struct
type position = int list
- let msg_with_position p pp =
+ let msg_with_position (p : position) pp =
let rec pp_rec = function
| [] -> mt ()
| [i] -> int i
@@ -50,7 +50,7 @@ module Make = functor(S : SearchProblem) -> struct
in
explore [1] s
- (*s Breadth first search. We use functional FIFOS à la Okasaki. *)
+ (*s Breadth first search. We use functional FIFOS à la Okasaki. *)
type 'a queue = 'a list * 'a list
@@ -58,7 +58,7 @@ module Make = functor(S : SearchProblem) -> struct
let empty = [],[]
- let push x (h,t) = (x::h,t)
+ let push x (h,t) : _ queue = (x::h,t)
let pop = function
| h, x::t -> x, (h,t)
diff --git a/lib/explore.mli b/lib/explore.mli
index aaf11229..f3679188 100644
--- a/lib/explore.mli
+++ b/lib/explore.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/lib/feedback.ml b/lib/feedback.ml
new file mode 100644
index 00000000..a5e16ea0
--- /dev/null
+++ b/lib/feedback.ml
@@ -0,0 +1,171 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+open Serialize
+
+type message_level =
+ | Debug of string
+ | Info
+ | Notice
+ | Warning
+ | Error
+
+type message = {
+ message_level : message_level;
+ message_content : string;
+}
+
+let of_message_level = function
+ | Debug s ->
+ Serialize.constructor "message_level" "debug" [Xml_datatype.PCData s]
+ | Info -> Serialize.constructor "message_level" "info" []
+ | Notice -> Serialize.constructor "message_level" "notice" []
+ | Warning -> Serialize.constructor "message_level" "warning" []
+ | Error -> Serialize.constructor "message_level" "error" []
+let to_message_level =
+ Serialize.do_match "message_level" (fun s args -> match s with
+ | "debug" -> Debug (Serialize.raw_string args)
+ | "info" -> Info
+ | "notice" -> Notice
+ | "warning" -> Warning
+ | "error" -> Error
+ | _ -> raise Serialize.Marshal_error)
+
+let of_message msg =
+ let lvl = of_message_level msg.message_level in
+ let content = Serialize.of_string msg.message_content in
+ Xml_datatype.Element ("message", [], [lvl; content])
+let to_message xml = match xml with
+ | Xml_datatype.Element ("message", [], [lvl; content]) -> {
+ message_level = to_message_level lvl;
+ message_content = Serialize.to_string content }
+ | _ -> raise Serialize.Marshal_error
+
+let is_message = function
+ | Xml_datatype.Element ("message", _, _) -> true
+ | _ -> false
+
+
+type edit_id = int
+type state_id = Stateid.t
+type edit_or_state_id = Edit of edit_id | State of state_id
+type route_id = int
+
+type feedback_content =
+ | Processed
+ | Incomplete
+ | Complete
+ | ErrorMsg of Loc.t * string
+ | ProcessingIn of string
+ | InProgress of int
+ | WorkerStatus of string * string
+ | Goals of Loc.t * string
+ | AddedAxiom
+ | GlobRef of Loc.t * string * string * string * string
+ | GlobDef of Loc.t * string * string * string
+ | FileDependency of string option * string
+ | FileLoaded of string * string
+ | Custom of Loc.t * string * xml
+ | Message of message
+
+type feedback = {
+ id : edit_or_state_id;
+ contents : feedback_content;
+ route : route_id;
+}
+
+let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with
+ | "addedaxiom", _ -> AddedAxiom
+ | "processed", _ -> Processed
+ | "processingin", [where] -> ProcessingIn (to_string where)
+ | "incomplete", _ -> Incomplete
+ | "complete", _ -> Complete
+ | "globref", [loc; filepath; modpath; ident; ty] ->
+ GlobRef(to_loc loc, to_string filepath,
+ to_string modpath, to_string ident, to_string ty)
+ | "globdef", [loc; ident; secpath; ty] ->
+ GlobDef(to_loc loc, to_string ident, to_string secpath, to_string ty)
+ | "errormsg", [loc; s] -> ErrorMsg (to_loc loc, to_string s)
+ | "inprogress", [n] -> InProgress (to_int n)
+ | "workerstatus", [ns] ->
+ let n, s = to_pair to_string to_string ns in
+ WorkerStatus(n,s)
+ | "goals", [loc;s] -> Goals (to_loc loc, to_string s)
+ | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x)
+ | "filedependency", [from; dep] ->
+ FileDependency (to_option to_string from, to_string dep)
+ | "fileloaded", [dirpath; filename] ->
+ FileLoaded (to_string dirpath, to_string filename)
+ | "message", [m] -> Message (to_message m)
+ | _ -> raise Marshal_error)
+let of_feedback_content = function
+ | AddedAxiom -> constructor "feedback_content" "addedaxiom" []
+ | Processed -> constructor "feedback_content" "processed" []
+ | ProcessingIn where ->
+ constructor "feedback_content" "processingin" [of_string where]
+ | Incomplete -> constructor "feedback_content" "incomplete" []
+ | Complete -> constructor "feedback_content" "complete" []
+ | GlobRef(loc, filepath, modpath, ident, ty) ->
+ constructor "feedback_content" "globref" [
+ of_loc loc;
+ of_string filepath;
+ of_string modpath;
+ of_string ident;
+ of_string ty ]
+ | GlobDef(loc, ident, secpath, ty) ->
+ constructor "feedback_content" "globdef" [
+ of_loc loc;
+ of_string ident;
+ of_string secpath;
+ of_string ty ]
+ | ErrorMsg(loc, s) ->
+ constructor "feedback_content" "errormsg" [of_loc loc; of_string s]
+ | InProgress n -> constructor "feedback_content" "inprogress" [of_int n]
+ | WorkerStatus(n,s) ->
+ constructor "feedback_content" "workerstatus"
+ [of_pair of_string of_string (n,s)]
+ | Goals (loc,s) ->
+ constructor "feedback_content" "goals" [of_loc loc;of_string s]
+ | Custom (loc, name, x) ->
+ constructor "feedback_content" "custom" [of_loc loc; of_string name; x]
+ | FileDependency (from, depends_on) ->
+ constructor "feedback_content" "filedependency" [
+ of_option of_string from;
+ of_string depends_on]
+ | FileLoaded (dirpath, filename) ->
+ constructor "feedback_content" "fileloaded" [
+ of_string dirpath;
+ of_string filename ]
+ | Message m -> constructor "feedback_content" "message" [ of_message m ]
+
+let of_edit_or_state_id = function
+ | Edit id -> ["object","edit"], of_edit_id id
+ | State id -> ["object","state"], Stateid.to_xml id
+
+let of_feedback msg =
+ let content = of_feedback_content msg.contents in
+ let obj, id = of_edit_or_state_id msg.id in
+ let route = string_of_int msg.route in
+ Element ("feedback", obj @ ["route",route], [id;content])
+let to_feedback xml = match xml with
+ | Element ("feedback", ["object","edit";"route",route], [id;content]) -> {
+ id = Edit(to_edit_id id);
+ route = int_of_string route;
+ contents = to_feedback_content content }
+ | Element ("feedback", ["object","state";"route",route], [id;content]) -> {
+ id = State(Stateid.of_xml id);
+ route = int_of_string route;
+ contents = to_feedback_content content }
+ | _ -> raise Marshal_error
+
+let is_feedback = function
+ | Element ("feedback", _, _) -> true
+ | _ -> false
+
+let default_route = 0
diff --git a/lib/feedback.mli b/lib/feedback.mli
new file mode 100644
index 00000000..52a0e9fe
--- /dev/null
+++ b/lib/feedback.mli
@@ -0,0 +1,68 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+(* Old plain messages (used to be in Pp) *)
+type message_level =
+ | Debug of string
+ | Info
+ | Notice
+ | Warning
+ | Error
+
+type message = {
+ message_level : message_level;
+ message_content : string;
+}
+
+val of_message : message -> xml
+val to_message : xml -> message
+val is_message : xml -> bool
+
+
+(** Coq "semantic" infos obtained during parsing/execution *)
+type edit_id = int
+type state_id = Stateid.t
+type edit_or_state_id = Edit of edit_id | State of state_id
+type route_id = int
+
+val default_route : route_id
+
+type feedback_content =
+ (* STM mandatory data (must be displayed) *)
+ | Processed
+ | Incomplete
+ | Complete
+ | ErrorMsg of Loc.t * string
+ (* STM optional data *)
+ | ProcessingIn of string
+ | InProgress of int
+ | WorkerStatus of string * string
+ (* Generally useful metadata *)
+ | Goals of Loc.t * string
+ | AddedAxiom
+ | GlobRef of Loc.t * string * string * string * string
+ | GlobDef of Loc.t * string * string * string
+ | FileDependency of string option * string
+ | FileLoaded of string * string
+ (* Extra metadata *)
+ | Custom of Loc.t * string * xml
+ (* Old generic messages *)
+ | Message of message
+
+type feedback = {
+ id : edit_or_state_id; (* The document part concerned *)
+ contents : feedback_content; (* The payload *)
+ route : route_id; (* Extra routing info *)
+}
+
+val of_feedback : feedback -> xml
+val to_feedback : xml -> feedback
+val is_feedback : xml -> bool
+
diff --git a/lib/flags.ml b/lib/flags.ml
index f6d98ba5..c8e7f7af 100644
--- a/lib/flags.ml
+++ b/lib/flags.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,47 +8,116 @@
let with_option o f x =
let old = !o in o:=true;
- try let r = f x in o := old; r
- with reraise -> o := old; raise reraise
+ try let r = f x in if !o = true then o := old; r
+ with reraise ->
+ let reraise = Backtrace.add_backtrace reraise in
+ let () = o := old in
+ Exninfo.iraise reraise
+
+let with_options ol f x =
+ let vl = List.map (!) ol in
+ let () = List.iter (fun r -> r := true) ol in
+ try
+ let r = f x in
+ let () = List.iter2 (:=) ol vl in r
+ with reraise ->
+ let reraise = Backtrace.add_backtrace reraise in
+ let () = List.iter2 (:=) ol vl in
+ Exninfo.iraise reraise
let without_option o f x =
let old = !o in o:=false;
+ try let r = f x in if !o = false then o := old; r
+ with reraise ->
+ let reraise = Backtrace.add_backtrace reraise in
+ let () = o := old in
+ Exninfo.iraise reraise
+
+let with_extra_values o l f x =
+ let old = !o in o:=old@l;
try let r = f x in o := old; r
- with reraise -> o := old; raise reraise
+ with reraise ->
+ let reraise = Backtrace.add_backtrace reraise in
+ let () = o := old in
+ Exninfo.iraise reraise
let boot = ref false
-
+let load_init = ref true
let batch_mode = ref false
-let debug = ref false
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+let compilation_mode = ref BuildVo
+
+type async_proofs = APoff | APonLazy | APon
+let async_proofs_mode = ref APoff
+type cache = Force
+let async_proofs_cache = ref None
+let async_proofs_n_workers = ref 1
+let async_proofs_n_tacworkers = ref 2
+let async_proofs_private_flags = ref None
+let async_proofs_full = ref false
+let async_proofs_never_reopen_branch = ref false
+let async_proofs_flags_for_workers = ref []
+let async_proofs_worker_id = ref "master"
+type priority = Low | High
+let async_proofs_worker_priority = ref Low
+let string_of_priority = function Low -> "low" | High -> "high"
+let priority_of_string = function
+ | "low" -> Low
+ | "high" -> High
+ | _ -> raise (Invalid_argument "priority_of_string")
+
+let async_proofs_is_worker () =
+ !async_proofs_worker_id <> "master"
+let async_proofs_is_master () =
+ !async_proofs_mode = APon && !async_proofs_worker_id = "master"
-let print_emacs = ref false
+let debug = ref false
+let in_debugger = ref false
+let in_toplevel = ref false
-let term_quality = ref false
+let profile = false
-let xml_export = ref false
+let print_emacs = ref false
+let coqtop_ui = ref false
-type load_proofs = Force | Lazy | Dont
+let ide_slave = ref false
+let ideslave_coqtop_flags = ref None
-let load_proofs = ref Lazy
+let time = ref false
let raw_print = ref false
let record_print = ref true
+let univ_print = ref false
+
+let we_are_parsing = ref false
+
(* Compatibility mode *)
(* Current means no particular compatibility consideration.
For correct comparisons, this constructor should remain the last one. *)
-type compat_version = V8_2 | V8_3 | Current
+type compat_version = V8_2 | V8_3 | V8_4 | Current
+
let compat_version = ref Current
-let version_strictly_greater v = !compat_version > v
+
+let version_strictly_greater v = match !compat_version, v with
+| V8_2, (V8_2 | V8_3 | V8_4 | Current) -> false
+| V8_3, (V8_3 | V8_4 | Current) -> false
+| V8_4, (V8_4 | Current) -> false
+| Current, Current -> false
+| V8_3, V8_2 -> true
+| V8_4, (V8_2 | V8_3) -> true
+| Current, (V8_2 | V8_3 | V8_4) -> true
+
let version_less_or_equal v = not (version_strictly_greater v)
let pr_version = function
| V8_2 -> "8.2"
| V8_3 -> "8.3"
+ | V8_4 -> "8.4"
| Current -> "current"
(* Translate *)
@@ -73,7 +142,23 @@ let auto_intros = ref true
let make_auto_intros flag = auto_intros := flag
let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros
-let hash_cons_proofs = ref true
+let universe_polymorphism = ref false
+let make_universe_polymorphism b = universe_polymorphism := b
+let is_universe_polymorphism () = !universe_polymorphism
+
+let local_polymorphic_flag = ref None
+let use_polymorphic_flag () =
+ match !local_polymorphic_flag with
+ | Some p -> local_polymorphic_flag := None; p
+ | None -> is_universe_polymorphism ()
+let make_polymorphic_flag b =
+ local_polymorphic_flag := Some b
+
+(** [program_mode] tells that Program mode has been activated, either
+ globally via [Set Program] or locally via the Program command prefix. *)
+
+let program_mode = ref false
+let is_program_mode () = !program_mode
let warn = ref true
let make_warn flag = warn := flag; ()
@@ -85,28 +170,8 @@ let print_hyps_limit = ref (None : int option)
let set_print_hyps_limit n = print_hyps_limit := n
let print_hyps_limit () = !print_hyps_limit
-(* A list of the areas of the system where "unsafe" operation
- * has been requested *)
-
-module Stringset = Set.Make(struct type t = string let compare = compare end)
-
-let unsafe_set = ref Stringset.empty
-let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set
-let is_unsafe s = Stringset.mem s !unsafe_set
-
(* Flags for external tools *)
-let subst_command_placeholder s t =
- let buff = Buffer.create (String.length s + String.length t) in
- let i = ref 0 in
- while (!i < String.length s) do
- if s.[!i] = '%' & !i+1 < String.length s & s.[!i+1] = 's'
- then (Buffer.add_string buff t;incr i)
- else Buffer.add_char buff s.[!i];
- incr i
- done;
- Buffer.contents buff
-
let browser_cmd_fmt =
try
let coq_netscape_remote_var = "COQREMOTEBROWSER" in
@@ -122,21 +187,9 @@ let is_standard_doc_url url =
url = Coq_config.wwwrefman ||
url = wwwcompatprefix ^ String.sub Coq_config.wwwrefman n (n'-n)
-(* same as in System, but copied here because of dependencies *)
-let canonical_path_name p =
- let current = Sys.getcwd () in
- Sys.chdir p;
- let result = Sys.getcwd () in
- Sys.chdir current;
- result
-
(* Options for changing coqlib *)
let coqlib_spec = ref false
-let coqlib = ref (
- (* same as Envars.coqroot, but copied here because of dependencies *)
- Filename.dirname
- (canonical_path_name (Filename.dirname Sys.executable_name))
-)
+let coqlib = ref "(not initialized yet)"
(* Options for changing camlbin (used by coqmktop) *)
let camlbin_spec = ref false
@@ -152,3 +205,11 @@ let default_inline_level = 100
let inline_level = ref default_inline_level
let set_inline_level = (:=) inline_level
let get_inline_level () = !inline_level
+
+(* Disabling native code compilation for conversion and normalization *)
+let no_native_compiler = ref Coq_config.no_native_compiler
+
+(* Print the mod uid associated to a vo file by the native compiler *)
+let print_mod_uid = ref false
+
+let tactic_context_compat = ref false
diff --git a/lib/flags.mli b/lib/flags.mli
index ede4629c..756d3b85 100644
--- a/lib/flags.mli
+++ b/lib/flags.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -9,24 +9,51 @@
(** Global options of the system. *)
val boot : bool ref
+val load_init : bool ref
val batch_mode : bool ref
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+val compilation_mode : compilation_mode ref
+
+type async_proofs = APoff | APonLazy | APon
+val async_proofs_mode : async_proofs ref
+type cache = Force
+val async_proofs_cache : cache option ref
+val async_proofs_n_workers : int ref
+val async_proofs_n_tacworkers : int ref
+val async_proofs_private_flags : string option ref
+val async_proofs_is_worker : unit -> bool
+val async_proofs_is_master : unit -> bool
+val async_proofs_full : bool ref
+val async_proofs_never_reopen_branch : bool ref
+val async_proofs_flags_for_workers : string list ref
+val async_proofs_worker_id : string ref
+type priority = Low | High
+val async_proofs_worker_priority : priority ref
+val string_of_priority : priority -> string
+val priority_of_string : string -> priority
val debug : bool ref
+val in_debugger : bool ref
+val in_toplevel : bool ref
+
+val profile : bool
val print_emacs : bool ref
+val coqtop_ui : bool ref
-val term_quality : bool ref
+val ide_slave : bool ref
+val ideslave_coqtop_flags : string option ref
-val xml_export : bool ref
+val time : bool ref
-type load_proofs = Force | Lazy | Dont
-val load_proofs : load_proofs ref
+val we_are_parsing : bool ref
val raw_print : bool ref
val record_print : bool ref
+val univ_print : bool ref
-type compat_version = V8_2 | V8_3 | Current
+type compat_version = V8_2 | V8_3 | V8_4 | Current
val compat_version : compat_version ref
val version_strictly_greater : compat_version -> bool
val version_less_or_equal : compat_version -> bool
@@ -48,25 +75,37 @@ val if_verbose : ('a -> unit) -> 'a -> unit
val make_auto_intros : bool -> unit
val is_auto_intros : unit -> bool
+val program_mode : bool ref
+val is_program_mode : unit -> bool
+
+(** Global universe polymorphism flag. *)
+val make_universe_polymorphism : bool -> unit
+val is_universe_polymorphism : unit -> bool
+
+(** Local universe polymorphism flag. *)
+val make_polymorphic_flag : bool -> unit
+val use_polymorphic_flag : unit -> bool
+
val make_warn : bool -> unit
val if_warn : ('a -> unit) -> 'a -> unit
-val hash_cons_proofs : bool ref
-
-(** Temporary activate an option (to activate option [o] on [f x y z],
+(** Temporarily activate an option (to activate option [o] on [f x y z],
use [with_option o (f x y) z]) *)
val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b
-(** Temporary deactivate an option *)
+(** As [with_option], but on several flags. *)
+val with_options : bool ref list -> ('a -> 'b) -> 'a -> 'b
+
+(** Temporarily deactivate an option *)
val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b
+(** Temporarily extends the reference to a list *)
+val with_extra_values : 'c list ref -> 'c list -> ('a -> 'b) -> 'a -> 'b
+
(** If [None], no limit *)
val set_print_hyps_limit : int option -> unit
val print_hyps_limit : unit -> int option
-val add_unsafe : string -> unit
-val is_unsafe : string -> bool
-
(** Options for external tools *)
(** Returns string format for default browser to use from Coq or CoqIDE *)
@@ -74,9 +113,6 @@ val browser_cmd_fmt : string
val is_standard_doc_url : string -> bool
-(** Substitute %s in the first chain by the second chain *)
-val subst_command_placeholder : string -> string -> string
-
(** Options for specifying where coq librairies reside *)
val coqlib_spec : bool ref
val coqlib : string ref
@@ -91,3 +127,13 @@ val camlp4bin : string ref
val set_inline_level : int -> unit
val get_inline_level : unit -> int
val default_inline_level : int
+
+(* Disabling native code compilation for conversion and normalization *)
+val no_native_compiler : bool ref
+
+(* Print the mod uid associated to a vo file by the native compiler *)
+val print_mod_uid : bool ref
+
+val tactic_context_compat : bool ref
+(** Set to [true] to trigger the compatibility bugged context matching (old
+ context vs. appcontext) is set. *)
diff --git a/lib/fmap.ml b/lib/fmap.ml
deleted file mode 100644
index 8ca56fe7..00000000
--- a/lib/fmap.ml
+++ /dev/null
@@ -1,133 +0,0 @@
-
-module Make = functor (X:Map.OrderedType) -> struct
- type key = X.t
- type 'a t =
- Empty
- | Node of 'a t * key * 'a * 'a t * int
-
- let empty = Empty
-
- let is_empty = function Empty -> true | _ -> false
-
- let height = function
- Empty -> 0
- | Node(_,_,_,_,h) -> h
-
- let create l x d r =
- let hl = height l and hr = height r in
- Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
- let bal l x d r =
- let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
- let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
- if hl > hr + 2 then begin
- match l with
- Empty -> invalid_arg "Map.bal"
- | Node(ll, lv, ld, lr, _) ->
- if height ll >= height lr then
- create ll lv ld (create lr x d r)
- else begin
- match lr with
- Empty -> invalid_arg "Map.bal"
- | Node(lrl, lrv, lrd, lrr, _)->
- create (create ll lv ld lrl) lrv lrd (create lrr x d r)
- end
- end else if hr > hl + 2 then begin
- match r with
- Empty -> invalid_arg "Map.bal"
- | Node(rl, rv, rd, rr, _) ->
- if height rr >= height rl then
- create (create l x d rl) rv rd rr
- else begin
- match rl with
- Empty -> invalid_arg "Map.bal"
- | Node(rll, rlv, rld, rlr, _) ->
- create (create l x d rll) rlv rld (create rlr rv rd rr)
- end
- end else
- Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
- let rec add x data = function
- Empty ->
- Node(Empty, x, data, Empty, 1)
- | Node(l, v, d, r, h) ->
- let c = X.compare x v in
- if c = 0 then
- Node(l, x, data, r, h)
- else if c < 0 then
- bal (add x data l) v d r
- else
- bal l v d (add x data r)
-
- let rec find x = function
- Empty ->
- raise Not_found
- | Node(l, v, d, r, _) ->
- let c = X.compare x v in
- if c = 0 then d
- else find x (if c < 0 then l else r)
-
- let rec mem x = function
- Empty ->
- false
- | Node(l, v, d, r, _) ->
- let c = X.compare x v in
- c = 0 || mem x (if c < 0 then l else r)
-
- let rec min_binding = function
- Empty -> raise Not_found
- | Node(Empty, x, d, r, _) -> (x, d)
- | Node(l, x, d, r, _) -> min_binding l
-
- let rec remove_min_binding = function
- Empty -> invalid_arg "Map.remove_min_elt"
- | Node(Empty, x, d, r, _) -> r
- | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
-
- let merge t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (_, _) ->
- let (x, d) = min_binding t2 in
- bal t1 x d (remove_min_binding t2)
-
- let rec remove x = function
- Empty ->
- Empty
- | Node(l, v, d, r, h) ->
- let c = X.compare x v in
- if c = 0 then
- merge l r
- else if c < 0 then
- bal (remove x l) v d r
- else
- bal l v d (remove x r)
-
- let rec iter f = function
- Empty -> ()
- | Node(l, v, d, r, _) ->
- iter f l; f v d; iter f r
-
- let rec map f = function
- Empty -> Empty
- | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
-
- (* Maintien de fold_right par compatibilité (changé en fold_left dans
- ocaml-3.09.0) *)
-
- let rec fold f m accu =
- match m with
- Empty -> accu
- | Node(l, v, d, r, _) ->
- fold f l (f v d (fold f r accu))
-
-(* Added with respect to ocaml standard library. *)
-
- let dom m = fold (fun x _ acc -> x::acc) m []
-
- let rng m = fold (fun _ y acc -> y::acc) m []
-
- let to_list m = fold (fun x y acc -> (x,y)::acc) m []
-
-end
diff --git a/lib/fmap.mli b/lib/fmap.mli
deleted file mode 100644
index 2c8dedd7..00000000
--- a/lib/fmap.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-
-module Make : functor (X : Map.OrderedType) ->
-sig
- type key = X.t
- 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
-val mem : key -> 'a t -> bool
-val iter : (key -> 'a -> unit) -> 'a t -> unit
-val map : ('a -> 'b) -> 'a t -> 'b t
-val fold : (key -> 'a -> 'c -> 'c) -> 'a t -> 'c -> 'c
-
-(** Additions with respect to ocaml standard library. *)
-
-val dom : 'a t -> key list
-val rng : 'a t -> 'a list
-val to_list : 'a t -> (key * 'a) list
-end
-
diff --git a/lib/fset.ml b/lib/fset.ml
deleted file mode 100644
index 567feaa7..00000000
--- a/lib/fset.ml
+++ /dev/null
@@ -1,235 +0,0 @@
-module Make = functor (X : Set.OrderedType) ->
-struct
-
- type elt = X.t
- type t = Empty | Node of t * elt * t * int
-
-
- (* Sets are represented by balanced binary trees (the heights of the
- children differ by at most 2 *)
-
- let height = function
- Empty -> 0
- | Node(_, _, _, h) -> h
-
- (* Creates a new node with left son l, value x and right son r.
- l and r must be balanced and | height l - height r | <= 2.
- Inline expansion of height for better speed. *)
-
- let create l x r =
- let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
- let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
- Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
-
- (* Same as create, but performs one step of rebalancing if necessary.
- Assumes l and r balanced.
- Inline expansion of create for better speed in the most frequent case
- where no rebalancing is required. *)
-
- let bal l x r =
- let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
- let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
- if hl > hr + 2 then begin
- match l with
- Empty -> invalid_arg "Set.bal"
- | Node(ll, lv, lr, _) ->
- if height ll >= height lr then
- create ll lv (create lr x r)
- else begin
- match lr with
- Empty -> invalid_arg "Set.bal"
- | Node(lrl, lrv, lrr, _)->
- create (create ll lv lrl) lrv (create lrr x r)
- end
- end else if hr > hl + 2 then begin
- match r with
- Empty -> invalid_arg "Set.bal"
- | Node(rl, rv, rr, _) ->
- if height rr >= height rl then
- create (create l x rl) rv rr
- else begin
- match rl with
- Empty -> invalid_arg "Set.bal"
- | Node(rll, rlv, rlr, _) ->
- create (create l x rll) rlv (create rlr rv rr)
- end
- end else
- Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
-
- (* Same as bal, but repeat rebalancing until the final result
- is balanced. *)
-
- let rec join l x r =
- match bal l x r with
- Empty -> invalid_arg "Set.join"
- | Node(l', x', r', _) as t' ->
- let d = height l' - height r' in
- if d < -2 or d > 2 then join l' x' r' else t'
-
- (* Merge two trees l and r into one.
- All elements of l must precede the elements of r.
- Assumes | height l - height r | <= 2. *)
-
- let rec merge t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
- bal l1 v1 (bal (merge r1 l2) v2 r2)
-
- (* Same as merge, but does not assume anything about l and r. *)
-
- let rec concat t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
- join l1 v1 (join (concat r1 l2) v2 r2)
-
- (* Splitting *)
-
- let rec split x = function
- Empty ->
- (Empty, None, Empty)
- | Node(l, v, r, _) ->
- let c = X.compare x v in
- if c = 0 then (l, Some v, r)
- else if c < 0 then
- let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
- else
- let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
-
- (* Implementation of the set operations *)
-
- let empty = Empty
-
- let is_empty = function Empty -> true | _ -> false
-
- let rec mem x = function
- Empty -> false
- | Node(l, v, r, _) ->
- let c = X.compare x v in
- c = 0 || mem x (if c < 0 then l else r)
-
- let rec add x = function
- Empty -> Node(Empty, x, Empty, 1)
- | Node(l, v, r, _) as t ->
- let c = X.compare x v in
- if c = 0 then t else
- if c < 0 then bal (add x l) v r else bal l v (add x r)
-
- let singleton x = Node(Empty, x, Empty, 1)
-
- let rec remove x = function
- Empty -> Empty
- | Node(l, v, r, _) ->
- let c = X.compare x v in
- if c = 0 then merge l r else
- if c < 0 then bal (remove x l) v r else bal l v (remove x r)
-
- let rec union s1 s2 =
- match (s1, s2) with
- (Empty, t2) -> t2
- | (t1, Empty) -> t1
- | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
- if h1 >= h2 then
- if h2 = 1 then add v2 s1 else begin
- let (l2, _, r2) = split v1 s2 in
- join (union l1 l2) v1 (union r1 r2)
- end
- else
- if h1 = 1 then add v1 s2 else begin
- let (l1, _, r1) = split v2 s1 in
- join (union l1 l2) v2 (union r1 r2)
- end
-
- let rec inter s1 s2 =
- match (s1, s2) with
- (Empty, t2) -> Empty
- | (t1, Empty) -> Empty
- | (Node(l1, v1, r1, _), t2) ->
- match split v1 t2 with
- (l2, None, r2) ->
- concat (inter l1 l2) (inter r1 r2)
- | (l2, Some _, r2) ->
- join (inter l1 l2) v1 (inter r1 r2)
-
- let rec diff s1 s2 =
- match (s1, s2) with
- (Empty, t2) -> Empty
- | (t1, Empty) -> t1
- | (Node(l1, v1, r1, _), t2) ->
- match split v1 t2 with
- (l2, None, r2) ->
- join (diff l1 l2) v1 (diff r1 r2)
- | (l2, Some _, 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) ->
- let c = 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)
-
- let compare s1 s2 =
- compare_aux [s1] [s2]
-
- let equal s1 s2 =
- compare s1 s2 = 0
-
- let rec subset s1 s2 =
- match (s1, s2) with
- Empty, _ ->
- true
- | _, Empty ->
- false
- | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
- let c = X.compare v1 v2 in
- if c = 0 then
- subset l1 l2 && subset r1 r2
- else if c < 0 then
- subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
- else
- subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
-
- let rec iter f = function
- Empty -> ()
- | Node(l, v, r, _) -> iter f l; f v; iter f r
-
- let rec fold f s accu =
- match s with
- Empty -> accu
- | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
-
- let rec cardinal = function
- Empty -> 0
- | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
-
- let rec elements_aux accu = function
- Empty -> accu
- | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
-
- let elements s =
- elements_aux [] s
-
- let rec min_elt = function
- Empty -> raise Not_found
- | Node(Empty, v, r, _) -> v
- | Node(l, v, r, _) -> min_elt l
-
- let rec max_elt = function
- Empty -> raise Not_found
- | Node(l, v, Empty, _) -> v
- | Node(l, v, r, _) -> max_elt r
-
- let choose = min_elt
-end
diff --git a/lib/fset.mli b/lib/fset.mli
deleted file mode 100644
index b1751d0b..00000000
--- a/lib/fset.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-module Make : functor (X : Set.OrderedType) ->
-sig
- type elt = X.t
- type t
-
-val empty : t
-val is_empty : t -> bool
-val mem : elt -> t -> bool
-val add : elt -> t -> t
-val singleton : elt -> t
-val remove : elt -> t -> t
-val union : t -> t -> t
-val inter : t -> t -> t
-val diff : t -> t -> t
-val compare : t -> t -> int
-val equal : t -> t -> bool
-val subset : t -> t -> bool
-val iter : ( elt -> unit) -> t -> unit
-val fold : (elt -> 'b -> 'b) -> t -> 'b -> 'b
-val cardinal : t -> int
-val elements : t -> elt list
-val min_elt : t -> elt
-val max_elt : t -> elt
-val choose : t -> elt
-end
diff --git a/lib/future.ml b/lib/future.ml
new file mode 100644
index 00000000..2f1ce5e4
--- /dev/null
+++ b/lib/future.ml
@@ -0,0 +1,220 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* To deal with side effects we have to save/restore the system state *)
+let freeze = ref (fun () -> assert false : unit -> Dyn.t)
+let unfreeze = ref (fun _ -> () : Dyn.t -> unit)
+let set_freeze f g = freeze := f; unfreeze := g
+
+exception NotReady
+exception NotHere
+let _ = Errors.register_handler (function
+ | NotReady ->
+ Pp.strbrk("The value you are asking for is not ready yet. " ^
+ "Please wait or pass "^
+ "the \"-async-proofs off\" option to CoqIDE to disable "^
+ "asynchronous script processing.")
+ | NotHere ->
+ Pp.strbrk("The value you are asking for is not available "^
+ "in this process. If you really need this, pass "^
+ "the \"-async-proofs off\" option to CoqIDE to disable "^
+ "asynchronous script processing.")
+ | _ -> raise Errors.Unhandled)
+
+type fix_exn = Exninfo.iexn -> Exninfo.iexn
+let id x = prerr_endline "Future: no fix_exn.\nYou have probably created a Future.computation from a value without passing the ~fix_exn argument. You probably want to chain with an already existing future instead."; x
+
+module UUID = struct
+ type t = int
+ let invalid = 0
+ let fresh =
+ let count = ref invalid in
+ fun () -> incr count; !count
+
+ let compare = compare
+ let equal = (==)
+end
+
+module UUIDMap = Map.Make(UUID)
+module UUIDSet = Set.Make(UUID)
+
+type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation]
+
+(* Val is not necessarily a final state, so the
+ computation restarts from the state stocked into Val *)
+and 'a comp =
+ | Delegated of (unit -> unit)
+ | Closure of (unit -> 'a)
+ | Val of 'a * Dyn.t option
+ | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *)
+
+and 'a comput =
+ | Ongoing of (UUID.t * fix_exn * 'a comp ref) Ephemeron.key
+ | Finished of 'a
+
+and 'a computation = 'a comput ref
+
+let create ?(uuid=UUID.fresh ()) f x =
+ ref (Ongoing (Ephemeron.create (uuid, f, Pervasives.ref x)))
+let get x =
+ match !x with
+ | Finished v -> UUID.invalid, id, ref (Val (v,None))
+ | Ongoing x ->
+ try Ephemeron.get x
+ with Ephemeron.InvalidKey ->
+ UUID.invalid, id, ref (Exn (NotHere, Exninfo.null))
+
+type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ]
+
+let is_over kx = let _, _, x = get kx in match !x with
+ | Val _ | Exn _ -> true
+ | Closure _ | Delegated _ -> false
+
+let is_val kx = let _, _, x = get kx in match !x with
+ | Val _ -> true
+ | Exn _ | Closure _ | Delegated _ -> false
+
+let is_exn kx = let _, _, x = get kx in match !x with
+ | Exn _ -> true
+ | Val _ | Closure _ | Delegated _ -> false
+
+let peek_val kx = let _, _, x = get kx in match !x with
+ | Val (v, _) -> Some v
+ | Exn _ | Closure _ | Delegated _ -> None
+
+let uuid kx = let id, _, _ = get kx in id
+
+let from_val ?(fix_exn=id) v = create fix_exn (Val (v, None))
+let from_here ?(fix_exn=id) v = create fix_exn (Val (v, Some (!freeze ())))
+
+let fix_exn_of ck = let _, fix_exn, _ = get ck in fix_exn
+
+let create_delegate ?(blocking=true) fix_exn =
+ let assignement signal ck = fun v ->
+ let _, fix_exn, c = get ck in
+ assert (match !c with Delegated _ -> true | _ -> false);
+ begin match v with
+ | `Val v -> c := Val (v, None)
+ | `Exn e -> c := Exn (fix_exn e)
+ | `Comp f -> let _, _, comp = get f in c := !comp end;
+ signal () in
+ let wait, signal =
+ if not blocking then (fun () -> raise NotReady), ignore else
+ let lock = Mutex.create () in
+ let cond = Condition.create () in
+ (fun () -> Mutex.lock lock; Condition.wait cond lock; Mutex.unlock lock),
+ (fun () -> Mutex.lock lock; Condition.broadcast cond; Mutex.unlock lock) in
+ let ck = create fix_exn (Delegated wait) in
+ ck, assignement signal ck
+
+(* TODO: get rid of try/catch to be stackless *)
+let rec compute ~pure ck : 'a value =
+ let _, fix_exn, c = get ck in
+ match !c with
+ | Val (x, _) -> `Val x
+ | Exn (e, info) -> `Exn (e, info)
+ | Delegated wait -> wait (); compute ~pure ck
+ | Closure f ->
+ try
+ let data = f () in
+ let state = if pure then None else Some (!freeze ()) in
+ c := Val (data, state); `Val data
+ with e ->
+ let e = Errors.push e in
+ let e = fix_exn e in
+ match e with
+ | (NotReady, _) -> `Exn e
+ | _ -> c := Exn e; `Exn e
+
+let force ~pure x = match compute ~pure x with
+ | `Val v -> v
+ | `Exn e -> Exninfo.iraise e
+
+let chain ~pure ck f =
+ let uuid, fix_exn, c = get ck in
+ create ~uuid fix_exn (match !c with
+ | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck))
+ | Exn _ as x -> x
+ | Val (v, None) when pure -> Closure (fun () -> f v)
+ | Val (v, Some _) when pure -> Closure (fun () -> f v)
+ | Val (v, Some state) -> Closure (fun () -> !unfreeze state; f v)
+ | Val (v, None) ->
+ match !ck with
+ | Finished _ -> Errors.anomaly(Pp.str
+ "Future.chain ~pure:false call on an already joined computation")
+ | Ongoing _ -> Errors.anomaly(Pp.strbrk(
+ "Future.chain ~pure:false call on a pure computation. "^
+ "This can happen if the computation was initial created with "^
+ "Future.from_val or if it was Future.chain ~pure:true with a "^
+ "function and later forced.")))
+
+let create fix_exn f = create fix_exn (Closure f)
+
+let replace kx y =
+ let _, _, x = get kx in
+ match !x with
+ | Exn _ -> x := Closure (fun () -> force ~pure:false y)
+ | _ -> Errors.anomaly
+ (Pp.str "A computation can be replaced only if is_exn holds")
+
+let purify f x =
+ let state = !freeze () in
+ try
+ let v = f x in
+ !unfreeze state;
+ v
+ with e ->
+ let e = Errors.push e in !unfreeze state; Exninfo.iraise e
+
+let transactify f x =
+ let state = !freeze () in
+ try f x
+ with e ->
+ let e = Errors.push e in !unfreeze state; Exninfo.iraise e
+
+let purify_future f x = if is_over x then f x else purify f x
+let compute x = purify_future (compute ~pure:false) x
+let force ~pure x = purify_future (force ~pure) x
+let chain ?(greedy=true) ~pure x f =
+ let y = chain ~pure x f in
+ if is_over x && greedy then ignore(force ~pure y);
+ y
+let force x = force ~pure:false x
+
+let join kx =
+ let v = force kx in
+ kx := Finished v;
+ v
+
+let sink kx = if is_val kx then ignore(join kx)
+
+let split2 ?greedy x =
+ chain ?greedy ~pure:true x (fun x -> fst x),
+ chain ?greedy ~pure:true x (fun x -> snd x)
+
+let map2 ?greedy f x l =
+ CList.map_i (fun i y ->
+ let xi = chain ?greedy ~pure:true x (fun x ->
+ try List.nth x i
+ with Failure _ | Invalid_argument _ ->
+ Errors.anomaly (Pp.str "Future.map2 length mismatch")) in
+ f xi y) 0 l
+
+let print f kx =
+ let open Pp in
+ let (uid, _, x) = get kx in
+ let uid =
+ if UUID.equal uid UUID.invalid then str "[#]"
+ else str "[" ++ int uid ++ str "]"
+ in
+ match !x with
+ | Delegated _ -> str "Delegated" ++ uid
+ | Closure _ -> str "Closure" ++ uid
+ | Val (x, None) -> str "PureVal" ++ uid ++ spc () ++ hov 0 (f x)
+ | Val (x, Some _) -> str "StateVal" ++ uid ++ spc () ++ hov 0 (f x)
+ | Exn (e, _) -> str "Exn" ++ uid ++ spc () ++ hov 0 (str (Printexc.to_string e))
diff --git a/lib/future.mli b/lib/future.mli
new file mode 100644
index 00000000..8a4fa0bd
--- /dev/null
+++ b/lib/future.mli
@@ -0,0 +1,162 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Futures: asynchronous computations with some purity enforcing
+ *
+ * A Future.computation is like a lazy_t but with some extra bells and whistles
+ * to deal with imperative code and eventual delegation to a slave process.
+ *
+ * Example of a simple scenario taken into account:
+ *
+ * let f = Future.from_here (number_of_constants (Global.env())) in
+ * let g = Future.chain ~pure:false f (fun n ->
+ * n = number_of_constants (Global.env())) in
+ * ...
+ * Lemmas.save_named ...;
+ * ...
+ * let b = Future.force g in
+ *
+ * The Future.computation f holds a (immediate, no lazy here) value.
+ * We then chain to obtain g that (will) hold false if (when it will be
+ * run) the global environment has a different number of constants, true
+ * if nothing changed.
+ * Before forcing g, we add to the global environment one more constant.
+ * When finally we force g. Its value is going to be *true*.
+ * This because Future.from_here stores in the computation not only the initial
+ * value but the entire system state. When g is forced the state is restored,
+ * hence Global.env() returns the environment that was actual when f was
+ * created.
+ * Last, forcing g is run protecting the system state, hence when g finishes,
+ * the actual system state is restored.
+ *
+ * If you compare this with lazy_t, you see that the value returned is *false*,
+ * that is counter intuitive and error prone.
+ *
+ * Still not all computations are impure and access/alter the system state.
+ * This class can be optimized by using ~pure:true, but there is no way to
+ * statically check if this flag is misused, hence use it with care.
+ *
+ * Other differences with lazy_t is that a future computation that produces
+ * and exception can be substituted for another computation of the same type.
+ * Moreover a future computation can be delegated to another execution entity
+ * that will be allowed to set the result. Finally future computations can
+ * always be marshalled: if they were joined before marshalling, they will
+ * hold the computed value (assuming it is itself marshallable), otherwise
+ * they will become invalid and accessing them raises a private exception.
+ *)
+
+(* Each computation has a unique id that is inherited by each offspring
+ * computation (chain, split, map...). Joined computations lose it. *)
+module UUID : sig
+ type t
+ val invalid : t
+
+ val compare : t -> t -> int
+ val equal : t -> t -> bool
+end
+
+module UUIDMap : Map.S with type key = UUID.t
+module UUIDSet : Set.S with type elt = UUID.t
+
+exception NotReady
+
+type 'a computation
+type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ]
+type fix_exn = Exninfo.iexn -> Exninfo.iexn
+
+(* Build a computation, no snapshot of the global state is taken. If you need
+ to grab a copy of the state start with from_here () and then chain.
+ fix_exn is used to enrich any exception raised
+ by forcing the computations or any computation that is chained after
+ it. It is used by STM to attach errors to their corresponding states,
+ and to communicate to the code catching the exception a valid state id. *)
+val create : fix_exn -> (unit -> 'a) -> 'a computation
+
+(* Usually from_val is used to create "fake" futures, to use the same API
+ as if a real asynchronous computations was there. In this case fixing
+ the exception is not needed, but *if* the future is chained, the fix_exn
+ argument should really be given *)
+val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation
+
+(* Like from_val, but also takes a snapshot of the global state. Morally
+ the value is not just the 'a but also the global system state *)
+val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation
+
+(* To get the fix_exn of a computation and build a Tacexpr.declaration_hook.
+ * When a future enters the environment a corresponding hook is run to perform
+ * some work. If this fails, then its failure has to be annotated with the
+ * same state id that corresponds to the future computation end. I.e. Qed
+ * is split into two parts, the lazy one (the future) and the eagher one
+ * (the hook), both performing some computations for the same state id. *)
+val fix_exn_of : 'a computation -> fix_exn
+
+(* Run remotely, returns the function to assign.
+ If not blocking (the default) it raises NotReady if forced before the
+ delage assigns it. *)
+type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation]
+val create_delegate :
+ ?blocking:bool -> fix_exn -> 'a computation * ('a assignement -> unit)
+
+(* Given a computation that is_exn, replace it by another one *)
+val replace : 'a computation -> 'a computation -> unit
+
+(* Inspect a computation *)
+val is_over : 'a computation -> bool
+val is_val : 'a computation -> bool
+val is_exn : 'a computation -> bool
+val peek_val : 'a computation -> 'a option
+val uuid : 'a computation -> UUID.t
+
+(* [chain greedy pure c f] chains computation [c] with [f].
+ * The [greedy] and [pure] parameters are tricky:
+ * [pure]:
+ * When pure is true, the returned computation will not keep a copy
+ * of the global state.
+ * [let c' = chain ~pure:true c f in let c'' = chain ~pure:false c' g in]
+ * is invalid. It works if one forces [c''] since the whole computation
+ * will be executed in one go. It will not work, and raise an anomaly, if
+ * one forces c' and then c''.
+ * [join c; chain ~pure:false c g] is invalid and fails at runtime.
+ * [force c; chain ~pure:false c g] is correct.
+ * [greedy]:
+ * The [greedy] parameter forces immediately the new computation if
+ * the old one is_over (Exn or Val). Defaults to true. *)
+val chain : ?greedy:bool -> pure:bool ->
+ 'a computation -> ('a -> 'b) -> 'b computation
+
+(* Forcing a computation *)
+val force : 'a computation -> 'a
+val compute : 'a computation -> 'a value
+
+(* Final call, no more *inpure* chain allowed since the state is lost.
+ * Also the fix_exn function is lost, hence error reporting can be incomplete
+ * in a computation obtained by chaining on a joined future. *)
+val join : 'a computation -> 'a
+
+(* Call this before stocking the future. If it is_val then it is joined *)
+val sink : 'a computation -> unit
+
+(*** Utility functions ************************************************* ***)
+val split2 : ?greedy:bool ->
+ ('a * 'b) computation -> 'a computation * 'b computation
+val map2 : ?greedy:bool ->
+ ('a computation -> 'b -> 'c) ->
+ 'a list computation -> 'b list -> 'c list
+
+(* Once set_freeze is called we can purify a computation *)
+val purify : ('a -> 'b) -> 'a -> 'b
+(* And also let a function alter the state but backtrack if it raises exn *)
+val transactify : ('a -> 'b) -> 'a -> 'b
+
+(** Debug: print a computation given an inner printing function. *)
+val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds
+
+(* These functions are needed to get rid of side effects.
+ Thy are set for the outermos layer of the system, since they have to
+ deal with the whole system state. *)
+val set_freeze : (unit -> Dyn.t) -> (Dyn.t -> unit) -> unit
diff --git a/lib/genarg.ml b/lib/genarg.ml
new file mode 100644
index 00000000..42458ecb
--- /dev/null
+++ b/lib/genarg.ml
@@ -0,0 +1,235 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Pp
+open Util
+
+type argument_type =
+ (* Basic types *)
+ | IntOrVarArgType
+ | IdentArgType
+ | VarArgType
+ (* Specific types *)
+ | GenArgType
+ | ConstrArgType
+ | ConstrMayEvalArgType
+ | QuantHypArgType
+ | OpenConstrArgType
+ | ConstrWithBindingsArgType
+ | BindingsArgType
+ | RedExprArgType
+ | ListArgType of argument_type
+ | OptArgType of argument_type
+ | PairArgType of argument_type * argument_type
+ | ExtraArgType of string
+
+let rec argument_type_eq arg1 arg2 = match arg1, arg2 with
+| IntOrVarArgType, IntOrVarArgType -> true
+| IdentArgType, IdentArgType -> true
+| VarArgType, VarArgType -> true
+| GenArgType, GenArgType -> true
+| ConstrArgType, ConstrArgType -> true
+| ConstrMayEvalArgType, ConstrMayEvalArgType -> true
+| QuantHypArgType, QuantHypArgType -> true
+| OpenConstrArgType, OpenConstrArgType -> true
+| ConstrWithBindingsArgType, ConstrWithBindingsArgType -> true
+| BindingsArgType, BindingsArgType -> true
+| RedExprArgType, RedExprArgType -> true
+| ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2
+| OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2
+| PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) ->
+ argument_type_eq arg1l arg2l && argument_type_eq arg1r arg2r
+| ExtraArgType s1, ExtraArgType s2 -> CString.equal s1 s2
+| _ -> false
+
+let rec pr_argument_type = function
+| IntOrVarArgType -> str "int_or_var"
+| IdentArgType -> str "ident"
+| VarArgType -> str "var"
+| GenArgType -> str "genarg"
+| ConstrArgType -> str "constr"
+| ConstrMayEvalArgType -> str "constr_may_eval"
+| QuantHypArgType -> str "qhyp"
+| OpenConstrArgType -> str "open_constr"
+| ConstrWithBindingsArgType -> str "constr_with_bindings"
+| BindingsArgType -> str "bindings"
+| RedExprArgType -> str "redexp"
+| ListArgType t -> pr_argument_type t ++ spc () ++ str "list"
+| OptArgType t -> pr_argument_type t ++ spc () ++ str "opt"
+| PairArgType (t1, t2) ->
+ str "("++ pr_argument_type t1 ++ spc () ++
+ str "*" ++ spc () ++ pr_argument_type t2 ++ str ")"
+| ExtraArgType s -> str s
+
+type ('raw, 'glob, 'top) genarg_type = argument_type
+
+type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type
+(** Alias for concision *)
+
+(* Dynamics but tagged by a type expression *)
+
+type rlevel
+type glevel
+type tlevel
+
+type 'a generic_argument = argument_type * Obj.t
+type raw_generic_argument = rlevel generic_argument
+type glob_generic_argument = glevel generic_argument
+type typed_generic_argument = tlevel generic_argument
+
+let rawwit t = t
+let glbwit t = t
+let topwit t = t
+
+let wit_list t = ListArgType t
+
+let wit_opt t = OptArgType t
+
+let wit_pair t1 t2 = PairArgType (t1,t2)
+
+let in_gen t o = (t,Obj.repr o)
+let out_gen t (t',o) = if argument_type_eq t t' then Obj.magic o else failwith "out_gen"
+let genarg_tag (s,_) = s
+
+let has_type (t, v) u = argument_type_eq t u
+
+let unquote x = x
+
+type ('a,'b) abstract_argument_type = argument_type
+type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type
+type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type
+type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type
+
+type ('a, 'b, 'c, 'l) cast = Obj.t
+
+let raw = Obj.obj
+let glb = Obj.obj
+let top = Obj.obj
+
+type ('r, 'l) unpacker =
+ { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r }
+
+let unpack pack (t, obj) = pack.unpacker t (Obj.obj obj)
+
+(** Type transformers *)
+
+type ('r, 'l) list_unpacker =
+ { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+ ('a list, 'b list, 'c list, 'l) cast -> 'r }
+
+let list_unpack pack (t, obj) = match t with
+| ListArgType t -> pack.list_unpacker t (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+type ('r, 'l) opt_unpacker =
+ { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+ ('a option, 'b option, 'c option, 'l) cast -> 'r }
+
+let opt_unpack pack (t, obj) = match t with
+| OptArgType t -> pack.opt_unpacker t (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+type ('r, 'l) pair_unpacker =
+ { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2.
+ ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+ (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r }
+
+let pair_unpack pack (t, obj) = match t with
+| PairArgType (t1, t2) -> pack.pair_unpacker t1 t2 (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+(** Creating args *)
+
+let (arg0_map : Obj.t option String.Map.t ref) = ref String.Map.empty
+
+let create_arg opt name =
+ if String.Map.mem name !arg0_map then
+ Errors.anomaly (str "generic argument already declared: " ++ str name)
+ else
+ let () = arg0_map := String.Map.add name (Obj.magic opt) !arg0_map in
+ ExtraArgType name
+
+let make0 = create_arg
+
+let default_empty_value t =
+ let rec aux = function
+ | ListArgType _ -> Some (Obj.repr [])
+ | OptArgType _ -> Some (Obj.repr None)
+ | PairArgType(t1, t2) ->
+ (match aux t1, aux t2 with
+ | Some v1, Some v2 -> Some (Obj.repr (v1, v2))
+ | _ -> None)
+ | ExtraArgType s ->
+ String.Map.find s !arg0_map
+ | _ -> None in
+ match aux t with
+ | Some v -> Some (Obj.obj v)
+ | None -> None
+
+(** Registering genarg-manipulating functions *)
+
+module type GenObj =
+sig
+ type ('raw, 'glb, 'top) obj
+ val name : string
+ val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option
+end
+
+module Register (M : GenObj) =
+struct
+ let arg0_map =
+ ref (String.Map.empty : (Obj.t, Obj.t, Obj.t) M.obj String.Map.t)
+
+ let register0 arg f = match arg with
+ | ExtraArgType s ->
+ if String.Map.mem s !arg0_map then
+ let msg = str M.name ++ str " function already registered: " ++ str s in
+ Errors.anomaly msg
+ else
+ arg0_map := String.Map.add s (Obj.magic f) !arg0_map
+ | _ -> assert false
+
+ let get_obj0 name =
+ try String.Map.find name !arg0_map
+ with Not_found ->
+ match M.default (ExtraArgType name) with
+ | None ->
+ Errors.anomaly (str M.name ++ str " function not found: " ++ str name)
+ | Some obj -> obj
+
+ (** For now, the following function is quite dummy and should only be applied
+ to an extra argument type, otherwise, it will badly fail. *)
+ let obj t = match t with
+ | ExtraArgType s -> Obj.magic (get_obj0 s)
+ | _ -> assert false
+
+end
+
+(** Hackish part *)
+
+let arg0_names = ref (String.Map.empty : string String.Map.t)
+(** We use this table to associate a name to a given witness, to use it with
+ the extension mechanism. This is REALLY ad-hoc, but I do not know how to
+ do so nicely either. *)
+
+let register_name0 t name = match t with
+| ExtraArgType s ->
+ let () = assert (not (String.Map.mem s !arg0_names)) in
+ arg0_names := String.Map.add s name !arg0_names
+| _ -> failwith "register_name0"
+
+let get_name0 name =
+ String.Map.find name !arg0_names
+
+module Unsafe =
+struct
+
+let inj tpe x = (tpe, x)
+let prj (_, x) = x
+
+end
diff --git a/lib/genarg.mli b/lib/genarg.mli
new file mode 100644
index 00000000..a269f927
--- /dev/null
+++ b/lib/genarg.mli
@@ -0,0 +1,278 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** The route of a generic argument, from parsing to evaluation.
+In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc.
+
+{% \begin{%}verbatim{% }%}
+ parsing in_raw out_raw
+ char stream ---> raw_object ---> raw_object generic_argument -------+
+ encapsulation decaps|
+ |
+ V
+ raw_object
+ |
+ globalization |
+ V
+ glob_object
+ |
+ encaps |
+ in_glob |
+ V
+ glob_object generic_argument
+ |
+ out in out_glob |
+ object <--- object generic_argument <--- object <--- glob_object <---+
+ | decaps encaps interp decaps
+ |
+ V
+effective use
+{% \end{%}verbatim{% }%}
+
+To distinguish between the uninterpreted (raw), globalized and
+interpreted worlds, we annotate the type [generic_argument] by a
+phantom argument which is either [constr_expr], [glob_constr] or
+[constr].
+
+Transformation for each type :
+{% \begin{%}verbatim{% }%}
+tag raw open type cooked closed type
+
+BoolArgType bool bool
+IntArgType int int
+IntOrVarArgType int or_var int
+StringArgType string (parsed w/ "") string
+PreIdentArgType string (parsed w/o "") (vernac only)
+IdentArgType true identifier identifier
+IdentArgType false identifier (pattern_ident) identifier
+IntroPatternArgType intro_pattern_expr intro_pattern_expr
+VarArgType identifier located identifier
+RefArgType reference global_reference
+QuantHypArgType quantified_hypothesis quantified_hypothesis
+ConstrArgType constr_expr constr
+ConstrMayEvalArgType constr_expr may_eval constr
+OpenConstrArgType open_constr_expr open_constr
+ConstrWithBindingsArgType constr_expr with_bindings constr with_bindings
+BindingsArgType constr_expr bindings constr bindings
+List0ArgType of argument_type
+List1ArgType of argument_type
+OptArgType of argument_type
+ExtraArgType of string '_a '_b
+{% \end{%}verbatim{% }%}
+*)
+
+(** {5 Generic types} *)
+
+type ('raw, 'glob, 'top) genarg_type
+(** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized
+ one, and ['top] the internalized one. *)
+
+type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type
+(** Alias for concision when the three types agree. *)
+
+val make0 : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type
+(** Create a new generic type of argument: force to associate
+ unique ML types at each of the three levels. *)
+
+val create_arg : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type
+(** Alias for [make0]. *)
+
+(** {5 Specialized types} *)
+
+(** All of [rlevel], [glevel] and [tlevel] must be non convertible
+ to ensure the injectivity of the type inference from type
+ ['co generic_argument] to [('a,'co) abstract_argument_type];
+ this guarantees that, for 'co fixed, the type of
+ out_gen is monomorphic over 'a, hence type-safe
+*)
+
+type rlevel
+type glevel
+type tlevel
+
+type ('a, 'co) abstract_argument_type
+(** Type at level ['co] represented by an OCaml value of type ['a]. *)
+
+type 'a raw_abstract_argument_type = ('a, rlevel) abstract_argument_type
+(** Specialized type at raw level. *)
+
+type 'a glob_abstract_argument_type = ('a, glevel) abstract_argument_type
+(** Specialized type at globalized level. *)
+
+type 'a typed_abstract_argument_type = ('a, tlevel) abstract_argument_type
+(** Specialized type at internalized level. *)
+
+(** {6 Projections} *)
+
+val rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type
+(** Projection on the raw type constructor. *)
+
+val glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type
+(** Projection on the globalized type constructor. *)
+
+val topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type
+(** Projection on the internalized type constructor. *)
+
+(** {5 Generic arguments} *)
+
+type 'a generic_argument
+(** A inhabitant of ['level generic_argument] is a inhabitant of some type at
+ level ['level], together with the representation of this type. *)
+
+type raw_generic_argument = rlevel generic_argument
+type glob_generic_argument = glevel generic_argument
+type typed_generic_argument = tlevel generic_argument
+
+(** {6 Constructors} *)
+
+val in_gen : ('a, 'co) abstract_argument_type -> 'a -> 'co generic_argument
+(** [in_gen t x] embeds an argument of type [t] into a generic argument. *)
+
+val out_gen : ('a, 'co) abstract_argument_type -> 'co generic_argument -> 'a
+(** [out_gen t x] recovers an argument of type [t] from a generic argument. It
+ fails if [x] has not the right dynamic type. *)
+
+val has_type : 'co generic_argument -> ('a, 'co) abstract_argument_type -> bool
+(** [has_type v t] tells whether [v] has type [t]. If true, it ensures that
+ [out_gen t v] will not raise a dynamic type exception. *)
+
+(** {6 Destructors} *)
+
+type ('a, 'b, 'c, 'l) cast
+
+val raw : ('a, 'b, 'c, rlevel) cast -> 'a
+val glb : ('a, 'b, 'c, glevel) cast -> 'b
+val top : ('a, 'b, 'c, tlevel) cast -> 'c
+
+type ('r, 'l) unpacker =
+ { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r }
+
+val unpack : ('r, 'l) unpacker -> 'l generic_argument -> 'r
+(** Existential-type destructors. *)
+
+(** {6 Manipulation of generic arguments}
+
+Those functions fail if they are applied to an argument which has not the right
+dynamic type. *)
+
+type ('r, 'l) list_unpacker =
+ { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+ ('a list, 'b list, 'c list, 'l) cast -> 'r }
+
+val list_unpack : ('r, 'l) list_unpacker -> 'l generic_argument -> 'r
+
+type ('r, 'l) opt_unpacker =
+ { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+ ('a option, 'b option, 'c option, 'l) cast -> 'r }
+
+val opt_unpack : ('r, 'l) opt_unpacker -> 'l generic_argument -> 'r
+
+type ('r, 'l) pair_unpacker =
+ { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2.
+ ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+ (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r }
+
+val pair_unpack : ('r, 'l) pair_unpacker -> 'l generic_argument -> 'r
+
+(** {6 Type reification} *)
+
+type argument_type =
+ (** Basic types *)
+ | IntOrVarArgType
+ | IdentArgType
+ | VarArgType
+ (** Specific types *)
+ | GenArgType
+ | ConstrArgType
+ | ConstrMayEvalArgType
+ | QuantHypArgType
+ | OpenConstrArgType
+ | ConstrWithBindingsArgType
+ | BindingsArgType
+ | RedExprArgType
+ | ListArgType of argument_type
+ | OptArgType of argument_type
+ | PairArgType of argument_type * argument_type
+ | ExtraArgType of string
+
+val argument_type_eq : argument_type -> argument_type -> bool
+
+val pr_argument_type : argument_type -> Pp.std_ppcmds
+(** Print a human-readable representation for a given type. *)
+
+val genarg_tag : 'a generic_argument -> argument_type
+
+val unquote : ('a, 'co) abstract_argument_type -> argument_type
+
+(** {6 Registering genarg-manipulating functions}
+
+ This is boilerplate code used here and there in the code of Coq. *)
+
+module type GenObj =
+sig
+ type ('raw, 'glb, 'top) obj
+ (** An object manipulating generic arguments. *)
+
+ val name : string
+ (** A name for such kind of manipulation, e.g. [interp]. *)
+
+ val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option
+ (** A generic object when there is no registered object for this type. *)
+end
+
+module Register (M : GenObj) :
+sig
+ val register0 : ('raw, 'glb, 'top) genarg_type ->
+ ('raw, 'glb, 'top) M.obj -> unit
+ (** Register a ground type manipulation function. *)
+
+ val obj : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) M.obj
+ (** Recover a manipulation function at a given type. *)
+
+end
+
+(** {5 Basic generic type constructors} *)
+
+(** {6 Parameterized types} *)
+
+val wit_list : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type
+val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type
+val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+ ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type
+
+(** {5 Magic used by the parser} *)
+
+val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option
+
+val register_name0 : ('a, 'b, 'c) genarg_type -> string -> unit
+(** Used by the extension to give a name to types. The string should be the
+ absolute path of the argument witness, e.g.
+ [register_name0 wit_toto "MyArg.wit_toto"]. *)
+
+val get_name0 : string -> string
+(** Return the absolute path of a given witness. *)
+
+(** {5 Unsafe loophole} *)
+
+module Unsafe :
+sig
+
+(** Unsafe magic functions. Not for kids. This is provided here as a loophole to
+ escape this module. Do NOT use outside of the dedicated areas. NOT. EVER. *)
+
+val inj : argument_type -> Obj.t -> 'lev generic_argument
+(** Injects an object as generic argument. !!!BEWARE!!! only do this as
+ [inj tpe x] where:
+
+ 1. [tpe] is the reification of a [('a, 'b, 'c) genarg_type];
+ 2. [x] has type ['a], ['b] or ['c] according to the return level ['lev]. *)
+
+val prj : 'lev generic_argument -> Obj.t
+(** Recover the contents of a generic argument. *)
+
+end
diff --git a/lib/gmap.ml b/lib/gmap.ml
deleted file mode 100644
index e1c68da0..00000000
--- a/lib/gmap.ml
+++ /dev/null
@@ -1,140 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* Maps using the generic comparison function of ocaml. Code borrowed from
- the ocaml standard library (Copyright 1996, INRIA). *)
-
- type ('a,'b) t =
- Empty
- | Node of ('a,'b) t * 'a * 'b * ('a,'b) t * int
-
- let empty = Empty
-
- let is_empty = function Empty -> true | _ -> false
-
- let height = function
- Empty -> 0
- | Node(_,_,_,_,h) -> h
-
- let create l x d r =
- let hl = height l and hr = height r in
- Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
- let bal l x d r =
- let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
- let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
- if hl > hr + 2 then begin
- match l with
- Empty -> invalid_arg "Map.bal"
- | Node(ll, lv, ld, lr, _) ->
- if height ll >= height lr then
- create ll lv ld (create lr x d r)
- else begin
- match lr with
- Empty -> invalid_arg "Map.bal"
- | Node(lrl, lrv, lrd, lrr, _)->
- create (create ll lv ld lrl) lrv lrd (create lrr x d r)
- end
- end else if hr > hl + 2 then begin
- match r with
- Empty -> invalid_arg "Map.bal"
- | Node(rl, rv, rd, rr, _) ->
- if height rr >= height rl then
- create (create l x d rl) rv rd rr
- else begin
- match rl with
- Empty -> invalid_arg "Map.bal"
- | Node(rll, rlv, rld, rlr, _) ->
- create (create l x d rll) rlv rld (create rlr rv rd rr)
- end
- end else
- Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
- let rec add x data = function
- Empty ->
- Node(Empty, x, data, Empty, 1)
- | Node(l, v, d, r, h) ->
- let c = Pervasives.compare x v in
- if c = 0 then
- Node(l, x, data, r, h)
- else if c < 0 then
- bal (add x data l) v d r
- else
- bal l v d (add x data r)
-
- let rec find x = function
- Empty ->
- raise Not_found
- | Node(l, v, d, r, _) ->
- let c = Pervasives.compare x v in
- if c = 0 then d
- else find x (if c < 0 then l else r)
-
- let rec mem x = function
- Empty ->
- false
- | Node(l, v, d, r, _) ->
- let c = Pervasives.compare x v in
- c = 0 || mem x (if c < 0 then l else r)
-
- let rec min_binding = function
- Empty -> raise Not_found
- | Node(Empty, x, d, r, _) -> (x, d)
- | Node(l, x, d, r, _) -> min_binding l
-
- let rec remove_min_binding = function
- Empty -> invalid_arg "Map.remove_min_elt"
- | Node(Empty, x, d, r, _) -> r
- | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
-
- let merge t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (_, _) ->
- let (x, d) = min_binding t2 in
- bal t1 x d (remove_min_binding t2)
-
- let rec remove x = function
- Empty ->
- Empty
- | Node(l, v, d, r, h) ->
- let c = Pervasives.compare x v in
- if c = 0 then
- merge l r
- else if c < 0 then
- bal (remove x l) v d r
- else
- bal l v d (remove x r)
-
- let rec iter f = function
- Empty -> ()
- | Node(l, v, d, r, _) ->
- iter f l; f v d; iter f r
-
- let rec map f = function
- Empty -> Empty
- | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
-
- (* Maintien de fold_right par compatibilité (changé en fold_left dans
- ocaml-3.09.0) *)
-
- let rec fold f m accu =
- match m with
- Empty -> accu
- | Node(l, v, d, r, _) ->
- fold f l (f v d (fold f r accu))
-
-(* Added with respect to ocaml standard library. *)
-
- let dom m = fold (fun x _ acc -> x::acc) m []
-
- let rng m = fold (fun _ y acc -> y::acc) m []
-
- let to_list m = fold (fun x y acc -> (x,y)::acc) m []
-
diff --git a/lib/gmap.mli b/lib/gmap.mli
deleted file mode 100644
index c2fb7d26..00000000
--- a/lib/gmap.mli
+++ /dev/null
@@ -1,28 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(** Maps using the generic comparison function of ocaml. Same interface as
- the module [Map] from the ocaml standard library. *)
-
-type ('a,'b) t
-
-val empty : ('a,'b) t
-val is_empty : ('a,'b) t -> bool
-val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
-val find : 'a -> ('a,'b) t -> 'b
-val remove : 'a -> ('a,'b) t -> ('a,'b) t
-val mem : 'a -> ('a,'b) t -> bool
-val iter : ('a -> 'b -> unit) -> ('a,'b) t -> unit
-val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
-val fold : ('a -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
-
-(** Additions with respect to ocaml standard library. *)
-
-val dom : ('a,'b) t -> 'a list
-val rng : ('a,'b) t -> 'b list
-val to_list : ('a,'b) t -> ('a * 'b) list
diff --git a/lib/hMap.ml b/lib/hMap.ml
new file mode 100644
index 00000000..f902eded
--- /dev/null
+++ b/lib/hMap.ml
@@ -0,0 +1,332 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module type HashedType =
+sig
+ type t
+ val compare : t -> t -> int
+ val hash : t -> int
+end
+
+module SetMake(M : HashedType) =
+struct
+ (** Hash Sets use hashes to prevent doing too many comparison tests. They
+ associate to each hash the set of keys having that hash.
+
+ Invariants:
+
+ 1. There is no empty set in the intmap.
+ 2. All values in the same set have the same hash, which is the int to
+ which it is associated in the intmap.
+ *)
+
+ module Set = Set.Make(M)
+
+ type elt = M.t
+
+ type t = Set.t Int.Map.t
+
+ let empty = Int.Map.empty
+
+ let is_empty = Int.Map.is_empty
+
+ let mem x s =
+ let h = M.hash x in
+ try
+ let m = Int.Map.find h s in
+ Set.mem x m
+ with Not_found -> false
+
+ let add x s =
+ let h = M.hash x in
+ try
+ let m = Int.Map.find h s in
+ let m = Set.add x m in
+ Int.Map.update h m s
+ with Not_found ->
+ let m = Set.singleton x in
+ Int.Map.add h m s
+
+ let singleton x =
+ let h = M.hash x in
+ let m = Set.singleton x in
+ Int.Map.singleton h m
+
+ let remove x s =
+ let h = M.hash x in
+ try
+ let m = Int.Map.find h s in
+ let m = Set.remove x m in
+ if Set.is_empty m then
+ Int.Map.remove h s
+ else
+ Int.Map.update h m s
+ with Not_found -> s
+
+ let union s1 s2 =
+ let fu _ m1 m2 = match m1, m2 with
+ | None, None -> None
+ | (Some _ as m), None | None, (Some _ as m) -> m
+ | Some m1, Some m2 -> Some (Set.union m1 m2)
+ in
+ Int.Map.merge fu s1 s2
+
+ let inter s1 s2 =
+ let fu _ m1 m2 = match m1, m2 with
+ | None, None -> None
+ | Some _, None | None, Some _ -> None
+ | Some m1, Some m2 ->
+ let m = Set.inter m1 m2 in
+ if Set.is_empty m then None else Some m
+ in
+ Int.Map.merge fu s1 s2
+
+ let diff s1 s2 =
+ let fu _ m1 m2 = match m1, m2 with
+ | None, None -> None
+ | (Some _ as m), None -> m
+ | None, Some _ -> None
+ | Some m1, Some m2 ->
+ let m = Set.diff m1 m2 in
+ if Set.is_empty m then None else Some m
+ in
+ Int.Map.merge fu s1 s2
+
+ let compare s1 s2 = Int.Map.compare Set.compare s1 s2
+
+ let equal s1 s2 = Int.Map.equal Set.equal s1 s2
+
+ let subset s1 s2 =
+ let check h m1 =
+ let m2 = try Int.Map.find h s2 with Not_found -> Set.empty in
+ Set.subset m1 m2
+ in
+ Int.Map.for_all check s1
+
+ let iter f s =
+ let fi _ m = Set.iter f m in
+ Int.Map.iter fi s
+
+ let fold f s accu =
+ let ff _ m accu = Set.fold f m accu in
+ Int.Map.fold ff s accu
+
+ let for_all f s =
+ let ff _ m = Set.for_all f m in
+ Int.Map.for_all ff s
+
+ let exists f s =
+ let fe _ m = Set.exists f m in
+ Int.Map.exists fe s
+
+ let filter f s =
+ let ff m = Set.filter f m in
+ let s = Int.Map.map ff s in
+ Int.Map.filter (fun _ m -> not (Set.is_empty m)) s
+
+ let partition f s =
+ let fold h m (sl, sr) =
+ let (ml, mr) = Set.partition f m in
+ let sl = if Set.is_empty ml then sl else Int.Map.add h ml sl in
+ let sr = if Set.is_empty mr then sr else Int.Map.add h mr sr in
+ (sl, sr)
+ in
+ Int.Map.fold fold s (Int.Map.empty, Int.Map.empty)
+
+ let cardinal s =
+ let fold _ m accu = accu + Set.cardinal m in
+ Int.Map.fold fold s 0
+
+ let elements s =
+ let fold _ m accu = Set.fold (fun x accu -> x :: accu) m accu in
+ Int.Map.fold fold s []
+
+ let min_elt _ = assert false (** Cannot be implemented efficiently *)
+
+ let max_elt _ = assert false (** Cannot be implemented efficiently *)
+
+ let choose s =
+ let (_, m) = Int.Map.choose s in
+ Set.choose m
+
+ let split s x = assert false (** Cannot be implemented efficiently *)
+
+end
+
+module Make(M : HashedType) =
+struct
+ (** This module is essentially the same as SetMake, except that we have maps
+ instead of sets in the intmap. Invariants are the same. *)
+ module Set = SetMake(M)
+ module Map = CMap.Make(M)
+
+ type key = M.t
+
+ type 'a t = 'a Map.t Int.Map.t
+
+ let empty = Int.Map.empty
+
+ let is_empty = Int.Map.is_empty
+
+ let mem k s =
+ let h = M.hash k in
+ try
+ let m = Int.Map.find h s in
+ Map.mem k m
+ with Not_found -> false
+
+ let add k x s =
+ let h = M.hash k in
+ try
+ let m = Int.Map.find h s in
+ let m = Map.add k x m in
+ Int.Map.update h m s
+ with Not_found ->
+ let m = Map.singleton k x in
+ Int.Map.add h m s
+
+ let singleton k x =
+ let h = M.hash k in
+ Int.Map.singleton h (Map.singleton k x)
+
+ let remove k s =
+ let h = M.hash k in
+ try
+ let m = Int.Map.find h s in
+ let m = Map.remove k m in
+ if Map.is_empty m then
+ Int.Map.remove h s
+ else
+ Int.Map.update h m s
+ with Not_found -> s
+
+ let merge f s1 s2 =
+ let fm h m1 m2 = match m1, m2 with
+ | None, None -> None
+ | Some m, None ->
+ let m = Map.merge f m Map.empty in
+ if Map.is_empty m then None
+ else Some m
+ | None, Some m ->
+ let m = Map.merge f Map.empty m in
+ if Map.is_empty m then None
+ else Some m
+ | Some m1, Some m2 ->
+ let m = Map.merge f m1 m2 in
+ if Map.is_empty m then None
+ else Some m
+ in
+ Int.Map.merge fm s1 s2
+
+ let compare f s1 s2 =
+ let fc m1 m2 = Map.compare f m1 m2 in
+ Int.Map.compare fc s1 s2
+
+ let equal f s1 s2 =
+ let fe m1 m2 = Map.equal f m1 m2 in
+ Int.Map.equal fe s1 s2
+
+ let iter f s =
+ let fi _ m = Map.iter f m in
+ Int.Map.iter fi s
+
+ let fold f s accu =
+ let ff _ m accu = Map.fold f m accu in
+ Int.Map.fold ff s accu
+
+ let for_all f s =
+ let ff _ m = Map.for_all f m in
+ Int.Map.for_all ff s
+
+ let exists f s =
+ let fe _ m = Map.exists f m in
+ Int.Map.exists fe s
+
+ let filter f s =
+ let ff m = Map.filter f m in
+ let s = Int.Map.map ff s in
+ Int.Map.filter (fun _ m -> not (Map.is_empty m)) s
+
+ let partition f s =
+ let fold h m (sl, sr) =
+ let (ml, mr) = Map.partition f m in
+ let sl = if Map.is_empty ml then sl else Int.Map.add h ml sl in
+ let sr = if Map.is_empty mr then sr else Int.Map.add h mr sr in
+ (sl, sr)
+ in
+ Int.Map.fold fold s (Int.Map.empty, Int.Map.empty)
+
+ let cardinal s =
+ let fold _ m accu = accu + Map.cardinal m in
+ Int.Map.fold fold s 0
+
+ let bindings s =
+ let fold _ m accu = Map.fold (fun k x accu -> (k, x) :: accu) m accu in
+ Int.Map.fold fold s []
+
+ let min_binding _ = assert false (** Cannot be implemented efficiently *)
+
+ let max_binding _ = assert false (** Cannot be implemented efficiently *)
+
+ let fold_left _ _ _ = assert false (** Cannot be implemented efficiently *)
+
+ let fold_right _ _ _ = assert false (** Cannot be implemented efficiently *)
+
+ let choose s =
+ let (_, m) = Int.Map.choose s in
+ Map.choose m
+
+ let find k s =
+ let h = M.hash k in
+ let m = Int.Map.find h s in
+ Map.find k m
+
+ let split k s = assert false (** Cannot be implemented efficiently *)
+
+ let map f s =
+ let fs m = Map.map f m in
+ Int.Map.map fs s
+
+ let mapi f s =
+ let fs m = Map.mapi f m in
+ Int.Map.map fs s
+
+ let modify k f s =
+ let h = M.hash k in
+ let m = Int.Map.find h s in
+ let m = Map.modify k f m in
+ Int.Map.update h m s
+
+ let bind f s =
+ let fb m = Map.bind f m in
+ Int.Map.map fb s
+
+ let domain s = Int.Map.map Map.domain s
+
+ let update k x s =
+ let h = M.hash k in
+ let m = Int.Map.find h s in
+ let m = Map.update k x m in
+ Int.Map.update h m s
+
+ let smartmap f s =
+ let fs m = Map.smartmap f m in
+ Int.Map.smartmap fs s
+
+ let smartmapi f s =
+ let fs m = Map.smartmapi f m in
+ Int.Map.smartmap fs s
+
+ module Unsafe =
+ struct
+ let map f s =
+ let fs m = Map.Unsafe.map f m in
+ Int.Map.map fs s
+ end
+
+end
diff --git a/lib/hMap.mli b/lib/hMap.mli
new file mode 100644
index 00000000..cdf933b2
--- /dev/null
+++ b/lib/hMap.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module type HashedType =
+sig
+ type t
+ val compare : t -> t -> int
+ (** Total ordering *)
+ val hash : t -> int
+ (** Hashing function compatible with [compare], i.e. [compare x y = 0] implies
+ [hash x = hash y]. *)
+end
+
+(** Hash maps are maps that take advantage of having a hash on keys. This is
+ essentially a hash table, except that it uses purely functional maps instead
+ of arrays.
+
+ CAVEAT: order-related functions like [fold] or [iter] do not respect the
+ provided order anymore! It's your duty to do something sensible to prevent
+ this if you need it. In particular, [min_binding] and [max_binding] are now
+ made meaningless.
+*)
+module Make(M : HashedType) : CMap.ExtS with type key = M.t
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
index d310713e..752e2634 100644
--- a/lib/hashcons.ml
+++ b/lib/hashcons.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -13,42 +13,39 @@
(* [t] is the type of object to hash-cons
* [u] is the type of hash-cons functions for the sub-structures
* of objects of type t (u usually has the form (t1->t1)*(t2->t2)*...).
- * [hash_sub u x] is a function that hash-cons the sub-structures of x using
+ * [hashcons u x] is a function that hash-cons the sub-structures of x using
* the hash-consing functions u provides.
* [equal] is a comparison function. It is allowed to use physical equality
- * on the sub-terms hash-consed by the hash_sub function.
+ * on the sub-terms hash-consed by the hashcons function.
* [hash] is the hash function given to the Hashtbl.Make function
*
* Note that this module type coerces to the argument of Hashtbl.Make.
*)
-module type Comp =
+module type HashconsedType =
sig
type t
type u
- val hash_sub : u -> t -> t
+ val hashcons : u -> t -> t
val equal : t -> t -> bool
val hash : t -> int
end
-(* The output is a function f such that
- * [f ()] has the side-effect of creating (internally) a hash-table of the
- * hash-consed objects. The result is a function taking the sub-hashcons
- * functions and an object, and hashcons it. It does not really make sense
- * to call f() with different sub-hcons functions. That's why we use the
- * wrappers simple_hcons, recursive_hcons, ... The latter just take as
- * argument the sub-hcons functions (the tables are created at that moment),
- * and returns the hcons function for t.
- *)
+(** The output is a function [generate] such that [generate args] creates a
+ hash-table of the hash-consed objects, together with [hcons], a function
+ taking a table and an object, and hashcons it. For simplicity of use, we use
+ the wrapper functions defined below. *)
module type S =
sig
type t
type u
- val f : unit -> (u -> t -> t)
+ type table
+ val generate : u -> table
+ val hcons : table -> t -> t
end
-module Make(X:Comp) =
+module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) =
struct
type t = X.t
type u = X.u
@@ -58,34 +55,29 @@ module Make(X:Comp) =
* w.r.t (=), although the equality on keys is X.equal. This is
* granted since we hcons the subterms before looking up in the table.
*)
- module Htbl = Hashtbl.Make(
- struct type t=X.t
- type u=X.u
- let hash=X.hash
- let equal x1 x2 = (*incr comparaison;*) X.equal x1 x2
- end)
-
- (* The table is created when () is applied.
- * Hashconsing is then very simple:
- * 1- hashcons the subterms using hash_sub and u
- * 2- look up in the table, if we do not get a hit, we add it
- *)
- let f () =
+ module Htbl = Hashset.Make(X)
+
+ type table = (Htbl.t * u)
+
+ let generate u =
let tab = Htbl.create 97 in
- (fun u x ->
- let y = X.hash_sub u x in
- (* incr acces;*)
- try let r = Htbl.find tab y in(* incr succes;*) r
- with Not_found -> Htbl.add tab y y; y)
+ (tab, u)
+
+ let hcons (tab, u) x =
+ let y = X.hashcons u x in
+ Htbl.repr (X.hash y) y tab
+
end
(* A few usefull wrappers:
- * takes as argument the function f above and build a function of type
+ * takes as argument the function [generate] above and build a function of type
* u -> t -> t that creates a fresh table each time it is applied to the
* sub-hcons functions. *)
(* For non-recursive types it is quite easy. *)
-let simple_hcons h u = h () u
+let simple_hcons h f u =
+ let table = h u in
+ fun x -> f table x
(* For a recursive type T, we write the module of sig Comp with u equals
* to (T -> T) * u0
@@ -93,28 +85,14 @@ let simple_hcons h u = h () u
* The second one to hashcons the other sub-structures.
* We just have to take the fixpoint of h
*)
-let recursive_hcons h u =
- let hc = h () in
- let rec hrec x = hc (hrec,u) x in
+let recursive_hcons h f u =
+ let loop = ref (fun _ -> assert false) in
+ let self x = !loop x in
+ let table = h (self, u) in
+ let hrec x = f table x in
+ let () = loop := hrec in
hrec
-(* If the structure may contain loops, use this one. *)
-let recursive_loop_hcons h u =
- let hc = h () in
- let rec hrec visited x =
- if List.memq x visited then x
- else hc (hrec (x::visited),u) x
- in
- hrec []
-
-(* For 2 mutually recursive types *)
-let recursive2_hcons h1 h2 u1 u2 =
- let hc1 = h1 () in
- let hc2 = h2 () in
- let rec hrec1 x = hc1 (hrec1,hrec2,u1) x
- and hrec2 x = hc2 (hrec1,hrec2,u2) x
- in (hrec1,hrec2)
-
(* A set of global hashcons functions *)
let hashcons_resets = ref []
let init() = List.iter (fun f -> f()) !hashcons_resets
@@ -132,15 +110,48 @@ let register_hcons h u =
(* Basic hashcons modules for string and obj. Integers do not need be
hashconsed. *)
+module type HashedType = sig type t val hash : t -> int end
+
+(* list *)
+module Hlist (D:HashedType) =
+ Make(
+ struct
+ type t = D.t list
+ type u = (t -> t) * (D.t -> D.t)
+ let hashcons (hrec,hdata) = function
+ | x :: l -> hdata x :: hrec l
+ | l -> l
+ let equal l1 l2 =
+ l1 == l2 ||
+ match l1, l2 with
+ | [], [] -> true
+ | x1::l1, x2::l2 -> x1==x2 && l1==l2
+ | _ -> false
+ let rec hash accu = function
+ | [] -> accu
+ | x :: l ->
+ let accu = Hashset.Combine.combine (D.hash x) accu in
+ hash accu l
+ let hash l = hash 0 l
+ end)
+
(* string *)
module Hstring = Make(
struct
type t = string
type u = unit
- let hash_sub () s =(* incr accesstr;*) s
- let equal s1 s2 =(* incr comparaisonstr;
- if*) s1=s2(* then (incr successtr; true) else false*)
- let hash = Hashtbl.hash
+ let hashcons () s =(* incr accesstr;*) s
+ external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+ (** Copy from CString *)
+ let rec hash len s i accu =
+ if i = len then accu
+ else
+ let c = Char.code (String.unsafe_get s i) in
+ hash len s (succ i) (accu * 19 + c)
+
+ let hash s =
+ let len = String.length s in
+ hash len s 0 0
end)
(* Obj.t *)
@@ -148,10 +159,10 @@ exception NotEq
(* From CAMLLIB/caml/mlvalues.h *)
let no_scan_tag = 251
-let tuple_p obj = Obj.is_block obj & (Obj.tag obj < no_scan_tag)
+let tuple_p obj = Obj.is_block obj && (Obj.tag obj < no_scan_tag)
let comp_obj o1 o2 =
- if tuple_p o1 & tuple_p o2 then
+ if tuple_p o1 && tuple_p o2 then
let n1 = Obj.size o1 and n2 = Obj.size o2 in
if n1=n2 then
try
@@ -176,7 +187,7 @@ module Hobj = Make(
struct
type t = Obj.t
type u = (Obj.t -> Obj.t) * unit
- let hash_sub (hrec,_) = hash_obj hrec
+ let hashcons (hrec,_) = hash_obj hrec
let equal = comp_obj
let hash = Hashtbl.hash
end)
@@ -186,8 +197,8 @@ module Hobj = Make(
*)
(* string : string -> string *)
(* obj : Obj.t -> Obj.t *)
-let string = register_hcons (simple_hcons Hstring.f) ()
-let obj = register_hcons (recursive_hcons Hobj.f) ()
+let string = register_hcons (simple_hcons Hstring.generate Hstring.hcons) ()
+let obj = register_hcons (recursive_hcons Hobj.generate Hobj.hcons) ()
(* The unsafe polymorphic hashconsing function *)
let magic_hash (c : 'a) =
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
index d2aa6462..60a9ee01 100644
--- a/lib/hashcons.mli
+++ b/lib/hashcons.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,43 +8,81 @@
(** Generic hash-consing. *)
-module type Comp =
+(** {6 Hashconsing functorial interface} *)
+
+module type HashconsedType =
sig
+ (** {6 Generic hashconsing signature}
+
+ Given an equivalence relation [equal], a hashconsing function is a
+ function that associates the same canonical element to two elements
+ related by [equal]. Usually, the element chosen is canonical w.r.t.
+ physical equality [(==)], so as to reduce memory consumption and
+ enhance efficiency of equality tests.
+
+ In order to ensure canonicality, we need a way to remember the element
+ associated to a class of equivalence; this is done using the table type
+ generated by the [Make] functor.
+ *)
+
type t
+ (** Type of objects to hashcons. *)
type u
- val hash_sub : u -> t -> t
+ (** Type of hashcons functions for the sub-structures contained in [t].
+ Usually a tuple of functions. *)
+ val hashcons : u -> t -> t
+ (** The actual hashconsing function, using its fist argument to recursively
+ hashcons substructures. It should be compatible with [equal], that is
+ [equal x (hashcons f x) = true]. *)
val equal : t -> t -> bool
+ (** A comparison function. It is allowed to use physical equality
+ on the sub-terms hashconsed by the [hashcons] function, but it should be
+ insensible to shallow copy of the compared object. *)
val hash : t -> int
+ (** A hash function passed to the underlying hashtable structure. [hash]
+ should be compatible with [equal], i.e. if [equal x y = true] then
+ [hash x = hash y]. *)
end
module type S =
sig
type t
+ (** Type of objects to hashcons. *)
type u
- val f : unit -> (u -> t -> t)
+ (** Type of hashcons functions for the sub-structures contained in [t]. *)
+ type table
+ (** Type of hashconsing tables *)
+ val generate : u -> table
+ (** This create a hashtable of the hashconsed objects. *)
+ val hcons : table -> t -> t
+ (** Perform the hashconsing of the given object within the table. *)
end
-module Make(X:Comp) : (S with type t = X.t and type u = X.u)
+module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u)
+(** Create a new hashconsing, given canonicalization functions. *)
-val simple_hcons : (unit -> 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive_hcons : (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive_loop_hcons :
- (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive2_hcons :
- (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u1 -> 't1 -> 't1) ->
- (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u2 -> 't2 -> 't2) ->
- 'u1 -> 'u2 -> ('t1 -> 't1) * ('t2 -> 't2)
+(** {6 Wrappers} *)
-(** Declaring and reinitializing global hash-consing functions *)
+(** These are intended to be used together with instances of the [Make]
+ functor. *)
-val init : unit -> unit
-val register_hcons : ('u -> 't -> 't) -> ('u -> 't -> 't)
+val simple_hcons : ('u -> 'tab) -> ('tab -> 't -> 't) -> 'u -> 't -> 't
+(** [simple_hcons f sub obj] creates a new table each time it is applied to any
+ sub-hash function [sub]. *)
-module Hstring : (S with type t = string and type u = unit)
-module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit)
+val recursive_hcons : (('t -> 't) * 'u -> 'tab) -> ('tab -> 't -> 't) -> ('u -> 't -> 't)
+(** As [simple_hcons] but intended to be used with well-founded data structures. *)
+
+(** {6 Hashconsing of usual structures} *)
-val string : string -> string
-val obj : Obj.t -> Obj.t
+module type HashedType = sig type t val hash : t -> int end
-val magic_hash : 'a -> 'a
+module Hstring : (S with type t = string and type u = unit)
+(** Hashconsing of strings. *)
+module Hlist (D:HashedType) :
+ (S with type t = D.t list and type u = (D.t list -> D.t list)*(D.t->D.t))
+(** Hashconsing of lists. *)
+
+module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit)
+(** Hashconsing of OCaml values. *)
diff --git a/lib/hashset.ml b/lib/hashset.ml
new file mode 100644
index 00000000..6bec81c7
--- /dev/null
+++ b/lib/hashset.ml
@@ -0,0 +1,203 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Adapted from Damien Doligez, projet Para, INRIA Rocquencourt,
+ OCaml stdlib. *)
+
+(** The following functor is a specialized version of [Weak.Make].
+ Here, the responsibility of computing the hash function is now
+ given to the caller, which makes possible the interleaving of the
+ hash key computation and the hash-consing. *)
+
+module type EqType = sig
+ type t
+ val equal : t -> t -> bool
+end
+
+module type S = sig
+ type elt
+ type t
+ val create : int -> t
+ val clear : t -> unit
+ val repr : int -> elt -> t -> elt
+end
+
+module Make (E : EqType) =
+ struct
+
+ type elt = E.t
+
+ let emptybucket = Weak.create 0
+
+ type t = {
+ mutable table : elt Weak.t array;
+ mutable hashes : int array array;
+ mutable limit : int; (* bucket size limit *)
+ mutable oversize : int; (* number of oversize buckets *)
+ mutable rover : int; (* for internal bookkeeping *)
+ }
+
+ let get_index t h = (h land max_int) mod (Array.length t.table)
+
+ let limit = 7
+ let over_limit = 2
+
+ let create sz =
+ let sz = if sz < 7 then 7 else sz in
+ let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
+ {
+ table = Array.make sz emptybucket;
+ hashes = Array.make sz [| |];
+ limit = limit;
+ oversize = 0;
+ rover = 0;
+ }
+
+ let clear t =
+ for i = 0 to Array.length t.table - 1 do
+ t.table.(i) <- emptybucket;
+ t.hashes.(i) <- [| |];
+ done;
+ t.limit <- limit;
+ t.oversize <- 0
+
+ let iter_weak f t =
+ let rec iter_bucket i j b =
+ if i >= Weak.length b then () else
+ match Weak.check b i with
+ | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b
+ | false -> iter_bucket (i+1) j b
+ in
+ for i = 0 to pred (Array.length t.table) do
+ iter_bucket 0 i (Array.unsafe_get t.table i)
+ done
+
+ let rec count_bucket i b accu =
+ if i >= Weak.length b then accu else
+ count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0))
+
+ let min x y = if x - y < 0 then x else y
+
+ let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length
+ let prev_sz n = ((n - 3) * 2 + 2) / 3
+
+ let test_shrink_bucket t =
+ let bucket = t.table.(t.rover) in
+ let hbucket = t.hashes.(t.rover) in
+ let len = Weak.length bucket in
+ let prev_len = prev_sz len in
+ let live = count_bucket 0 bucket 0 in
+ if live <= prev_len then begin
+ let rec loop i j =
+ if j >= prev_len then begin
+ if Weak.check bucket i then loop (i + 1) j
+ else if Weak.check bucket j then begin
+ Weak.blit bucket j bucket i 1;
+ hbucket.(i) <- hbucket.(j);
+ loop (i + 1) (j - 1);
+ end else loop i (j - 1);
+ end;
+ in
+ loop 0 (Weak.length bucket - 1);
+ if prev_len = 0 then begin
+ t.table.(t.rover) <- emptybucket;
+ t.hashes.(t.rover) <- [| |];
+ end else begin
+ Obj.truncate (Obj.repr bucket) (prev_len + 1);
+ Obj.truncate (Obj.repr hbucket) prev_len;
+ end;
+ if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
+ end;
+ t.rover <- (t.rover + 1) mod (Array.length t.table)
+
+ let rec resize t =
+ let oldlen = Array.length t.table in
+ let newlen = next_sz oldlen in
+ if newlen > oldlen then begin
+ let newt = create newlen in
+ let add_weak ob oh oi =
+ let setter nb ni _ = Weak.blit ob oi nb ni 1 in
+ let h = oh.(oi) in
+ add_aux newt setter None h (get_index newt h);
+ in
+ iter_weak add_weak t;
+ t.table <- newt.table;
+ t.hashes <- newt.hashes;
+ t.limit <- newt.limit;
+ t.oversize <- newt.oversize;
+ t.rover <- t.rover mod Array.length newt.table;
+ end else begin
+ t.limit <- max_int; (* maximum size already reached *)
+ t.oversize <- 0;
+ end
+
+ and add_aux t setter d h index =
+ let bucket = t.table.(index) in
+ let hashes = t.hashes.(index) in
+ let sz = Weak.length bucket in
+ let rec loop i =
+ if i >= sz then begin
+ let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in
+ if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
+ let newbucket = Weak.create newsz in
+ let newhashes = Array.make newsz 0 in
+ Weak.blit bucket 0 newbucket 0 sz;
+ Array.blit hashes 0 newhashes 0 sz;
+ setter newbucket sz d;
+ newhashes.(sz) <- h;
+ t.table.(index) <- newbucket;
+ t.hashes.(index) <- newhashes;
+ if sz <= t.limit && newsz > t.limit then begin
+ t.oversize <- t.oversize + 1;
+ for i = 0 to over_limit do test_shrink_bucket t done;
+ end;
+ if t.oversize > Array.length t.table / over_limit then resize t
+ end else if Weak.check bucket i then begin
+ loop (i + 1)
+ end else begin
+ setter bucket i d;
+ hashes.(i) <- h
+ end
+ in
+ loop 0
+
+ let find_or h t d ifnotfound =
+ let index = get_index t h in
+ let bucket = t.table.(index) in
+ let hashes = t.hashes.(index) in
+ let sz = Weak.length bucket in
+ let rec loop i =
+ if i >= sz then ifnotfound index
+ else if h = hashes.(i) then begin
+ match Weak.get bucket i with
+ | Some v when E.equal v d -> v
+ | _ -> loop (i + 1)
+ end else loop (i + 1)
+ in
+ loop 0
+
+ let repr h d t =
+ let ifnotfound index = add_aux t Weak.set (Some d) h index; d in
+ find_or h t d ifnotfound
+
+end
+
+module Combine = struct
+ (* These are helper functions to combine the hash keys in a similar
+ way as [Hashtbl.hash] does. The constants [alpha] and [beta] must
+ be prime numbers. There were chosen empirically. Notice that the
+ problem of hashing trees is hard and there are plenty of study on
+ this topic. Therefore, there must be room for improvement here. *)
+ let alpha = 65599
+ let beta = 7
+ let combine x y = x * alpha + y
+ let combine3 x y z = combine x (combine y z)
+ let combine4 x y z t = combine x (combine3 y z t)
+ let combine5 x y z t u = combine x (combine4 y z t u)
+ let combinesmall x y = beta * x + y
+end
diff --git a/lib/hashset.mli b/lib/hashset.mli
new file mode 100644
index 00000000..537f3418
--- /dev/null
+++ b/lib/hashset.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Adapted from Damien Doligez, projet Para, INRIA Rocquencourt,
+ OCaml stdlib. *)
+
+(** The following functor is a specialized version of [Weak.Make].
+ Here, the responsibility of computing the hash function is now
+ given to the caller, which makes possible the interleaving of the
+ hash key computation and the hash-consing. *)
+
+module type EqType = sig
+ type t
+ val equal : t -> t -> bool
+end
+
+module type S = sig
+ type elt
+ (** Type of hashsets elements. *)
+ type t
+ (** Type of hashsets. *)
+ val create : int -> t
+ (** [create n] creates a fresh hashset with initial size [n]. *)
+ val clear : t -> unit
+ (** Clear the contents of a hashset. *)
+ val repr : int -> elt -> t -> elt
+ (** [repr key constr set] uses [key] to look for [constr]
+ in the hashet [set]. If [constr] is in [set], returns the
+ specific representation that is stored in [set]. Otherwise,
+ [constr] is stored in [set] and will be used as the canonical
+ representation of this value in the future. *)
+end
+
+module Make (E : EqType) : S with type elt = E.t
+
+module Combine : sig
+ val combine : int -> int -> int
+ val combinesmall : int -> int -> int
+ val combine3 : int -> int -> int -> int
+ val combine4 : int -> int -> int -> int -> int
+ val combine5 : int -> int -> int -> int -> int -> int
+end
diff --git a/lib/hashtbl_alt.ml b/lib/hashtbl_alt.ml
deleted file mode 100644
index 14b439ec..00000000
--- a/lib/hashtbl_alt.ml
+++ /dev/null
@@ -1,109 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* The following module is a specialized version of [Hashtbl] that is
- a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
- with [constr] used both as a key and as an image. Thus, in each
- cell of the internal bucketlist, there are two representations of
- the same value. In this implementation, there is only one.
-
- Besides, the responsibility of computing the hash function is now
- given to the caller, which makes possible the interleaving of the
- hash key computation and the hash-consing. *)
-
-module type Hashtype = sig
- type t
- val equals : t -> t -> bool
-end
-
-module type S = sig
- type elt
- (* [may_add_and_get key constr] uses [key] to look for [constr]
- in the hash table [H]. If [constr] is in [H], returns the
- specific representation that is stored in [H]. Otherwise,
- [constr] is stored in [H] and will be used as the canonical
- representation of this value in the future. *)
- val may_add_and_get : int -> elt -> elt
-end
-
-module Make (E : Hashtype) =
- struct
-
- type elt = E.t
-
- type bucketlist = Empty | Cons of elt * int * bucketlist
-
- let initial_size = 19991
- let table_data = ref (Array.make initial_size Empty)
- let table_size = ref 0
-
- let resize () =
- let odata = !table_data in
- let osize = Array.length odata in
- let nsize = min (2 * osize + 1) Sys.max_array_length in
- if nsize <> osize then begin
- let ndata = Array.create nsize Empty in
- let rec insert_bucket = function
- | Empty -> ()
- | Cons (key, hash, rest) ->
- let nidx = hash mod nsize in
- ndata.(nidx) <- Cons (key, hash, ndata.(nidx));
- insert_bucket rest
- in
- for i = 0 to osize - 1 do insert_bucket odata.(i) done;
- table_data := ndata
- end
-
- let add hash key =
- let odata = !table_data in
- let osize = Array.length odata in
- let i = hash mod osize in
- odata.(i) <- Cons (key, hash, odata.(i));
- incr table_size;
- if !table_size > osize lsl 1 then resize ()
-
- let find_rec hash key bucket =
- let rec aux = function
- | Empty ->
- add hash key; key
- | Cons (k, h, rest) ->
- if hash == h && E.equals key k then k else aux rest
- in
- aux bucket
-
- let may_add_and_get hash key =
- let odata = !table_data in
- match odata.(hash mod (Array.length odata)) with
- | Empty -> add hash key; key
- | Cons (k1, h1, rest1) ->
- if hash == h1 && E.equals key k1 then k1 else
- match rest1 with
- | Empty -> add hash key; key
- | Cons (k2, h2, rest2) ->
- if hash == h2 && E.equals key k2 then k2 else
- match rest2 with
- | Empty -> add hash key; key
- | Cons (k3, h3, rest3) ->
- if hash == h3 && E.equals key k3 then k3
- else find_rec hash key rest3
-
-end
-
-module Combine = struct
- (* These are helper functions to combine the hash keys in a similar
- way as [Hashtbl.hash] does. The constants [alpha] and [beta] must
- be prime numbers. There were chosen empirically. Notice that the
- problem of hashing trees is hard and there are plenty of study on
- this topic. Therefore, there must be room for improvement here. *)
- let alpha = 65599
- let beta = 7
- let combine x y = x * alpha + y
- let combine3 x y z = combine x (combine y z)
- let combine4 x y z t = combine x (combine3 y z t)
- let combinesmall x y = beta * x + y
-end
diff --git a/lib/hashtbl_alt.mli b/lib/hashtbl_alt.mli
deleted file mode 100644
index f14fd90f..00000000
--- a/lib/hashtbl_alt.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* The following module is a specialized version of [Hashtbl] that is
- a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
- with [constr] used both as a key and as an image. Thus, in each
- cell of the internal bucketlist, there are two representations of
- the same value. In this implementation, there is only one.
-
- Besides, the responsibility of computing the hash function is now
- given to the caller, which makes possible the interleaving of the
- hash key computation and the hash-consing. *)
-
-module type Hashtype = sig
- type t
- val equals : t -> t -> bool
-end
-
-module type S = sig
- type elt
- (* [may_add_and_get key constr] uses [key] to look for [constr]
- in the hash table [H]. If [constr] is in [H], returns the
- specific representation that is stored in [H]. Otherwise,
- [constr] is stored in [H] and will be used as the canonical
- representation of this value in the future. *)
- val may_add_and_get : int -> elt -> elt
-end
-
-module Make (E : Hashtype) : S with type elt = E.t
-
-module Combine : sig
- val combine : int -> int -> int
- val combinesmall : int -> int -> int
- val combine3 : int -> int -> int -> int
- val combine4 : int -> int -> int -> int -> int
-end
diff --git a/lib/heap.ml b/lib/heap.ml
index 372cecfc..a19bc0d1 100644
--- a/lib/heap.ml
+++ b/lib/heap.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -51,101 +51,86 @@ exception EmptyHeap
module Functional(X : Ordered) = struct
- (* Heaps are encoded as complete binary trees, i.e., binary trees
- which are full expect, may be, on the bottom level where it is filled
- from the left.
- These trees also enjoy the heap property, namely the value of any node
- is greater or equal than those of its left and right subtrees.
-
- There are 4 kinds of complete binary trees, denoted by 4 constructors:
- [FFF] for a full binary tree (and thus 2 full subtrees);
- [PPF] for a partial tree with a partial left subtree and a full
- right subtree;
- [PFF] for a partial tree with a full left subtree and a full right subtree
- (but of different heights);
- and [PFP] for a partial tree with a full left subtree and a partial
- right subtree. *)
+ (* Heaps are encoded as Braun trees, that are binary trees
+ where size r <= size l <= size r + 1 for each node Node (l, x, r) *)
type t =
- | Empty
- | FFF of t * X.t * t (* full (full, full) *)
- | PPF of t * X.t * t (* partial (partial, full) *)
- | PFF of t * X.t * t (* partial (full, full) *)
- | PFP of t * X.t * t (* partial (full, partial) *)
+ | Leaf
+ | Node of t * X.t * t
type elt = X.t
- let empty = Empty
+ let empty = Leaf
- (* smart constructors for insertion *)
- let p_f l x r = match l with
- | Empty | FFF _ -> PFF (l, x, r)
- | _ -> PPF (l, x, r)
-
- let pf_ l x = function
- | Empty | FFF _ as r -> FFF (l, x, r)
- | r -> PFP (l, x, r)
+ let is_empty t = t = Leaf
let rec add x = function
- | Empty ->
- FFF (Empty, x, Empty)
- (* insertion to the left *)
- | FFF (l, y, r) | PPF (l, y, r) ->
- if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r
- (* insertion to the right *)
- | PFF (l, y, r) | PFP (l, y, r) ->
- if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r)
+ | Leaf ->
+ Node (Leaf, x, Leaf)
+ | Node (l, y, r) ->
+ if X.compare x y >= 0 then
+ Node (add y r, x, l)
+ else
+ Node (add x r, y, l)
+
+ let rec extract = function
+ | Leaf ->
+ assert false
+ | Node (Leaf, y, r) ->
+ assert (r = Leaf);
+ y, Leaf
+ | Node (l, y, r) ->
+ let x, l = extract l in
+ x, Node (r, y, l)
+
+ let is_above x = function
+ | Leaf -> true
+ | Node (_, y, _) -> X.compare x y >= 0
+
+ let rec replace_min x = function
+ | Node (l, _, r) when is_above x l && is_above x r ->
+ Node (l, x, r)
+ | Node ((Node (_, lx, _) as l), _, r) when is_above lx r ->
+ (* lx <= x, rx necessarily *)
+ Node (replace_min x l, lx, r)
+ | Node (l, _, (Node (_, rx, _) as r)) ->
+ (* rx <= x, lx necessarily *)
+ Node (l, rx, replace_min x r)
+ | Leaf | Node (Leaf, _, _) | Node (_, _, Leaf) ->
+ assert false
+
+ (* merges two Braun trees [l] and [r],
+ with the assumption that [size r <= size l <= size r + 1] *)
+ let rec merge l r = match l, r with
+ | _, Leaf ->
+ l
+ | Node (ll, lx, lr), Node (_, ly, _) ->
+ if X.compare lx ly >= 0 then
+ Node (r, lx, merge ll lr)
+ else
+ let x, l = extract l in
+ Node (replace_min x r, ly, l)
+ | Leaf, _ ->
+ assert false (* contradicts the assumption *)
let maximum = function
- | Empty -> raise EmptyHeap
- | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x
-
- (* smart constructors for removal; note that they are different
- from the ones for insertion! *)
- let p_f l x r = match l with
- | Empty | FFF _ -> FFF (l, x, r)
- | _ -> PPF (l, x, r)
-
- let pf_ l x = function
- | Empty | FFF _ as r -> PFF (l, x, r)
- | r -> PFP (l, x, r)
-
- let rec remove = function
- | Empty ->
- raise EmptyHeap
- | FFF (Empty, _, Empty) ->
- Empty
- | PFF (l, _, Empty) ->
- l
- (* remove on the left *)
- | PPF (l, x, r) | PFF (l, x, r) ->
- let xl = maximum l in
- let xr = maximum r in
- let l' = remove l in
- if X.compare xl xr >= 0 then
- p_f l' xl r
- else
- p_f l' xr (add xl (remove r))
- (* remove on the right *)
- | FFF (l, x, r) | PFP (l, x, r) ->
- let xl = maximum l in
- let xr = maximum r in
- let r' = remove r in
- if X.compare xl xr > 0 then
- pf_ (add xr (remove l)) xl r'
- else
- pf_ l xr r'
+ | Leaf -> raise EmptyHeap
+ | Node (_, x, _) -> x
+
+ let remove = function
+ | Leaf ->
+ raise EmptyHeap
+ | Node (l, _, r) ->
+ merge l r
let rec iter f = function
- | Empty ->
- ()
- | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) ->
- iter f l; f x; iter f r
+ | Leaf -> ()
+ | Node (l, x, r) -> iter f l; f x; iter f r
let rec fold f h x0 = match h with
- | Empty ->
+ | Leaf ->
x0
- | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) ->
+ | Node (l, x, r) ->
fold f l (fold f r (f x x0))
end
diff --git a/lib/heap.mli b/lib/heap.mli
index ee86e814..a69de34c 100644
--- a/lib/heap.mli
+++ b/lib/heap.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/lib/hook.ml b/lib/hook.ml
new file mode 100644
index 00000000..0aa373c2
--- /dev/null
+++ b/lib/hook.ml
@@ -0,0 +1,32 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type 'a content =
+| Unset
+| Default of 'a
+| Set of 'a
+
+type 'a t = 'a content ref
+
+type 'a value = 'a t
+
+let get (hook : 'a value) = match !hook with
+| Unset -> assert false
+| Default data | Set data -> data
+
+let set (hook : 'a t) data = match !hook with
+| Unset | Default _ -> hook := Set data
+| Set _ -> assert false
+
+let make ?default () =
+ let data = match default with
+ | None -> Unset
+ | Some data -> Default data
+ in
+ let ans = ref data in
+ (ans, ans)
diff --git a/lib/hook.mli b/lib/hook.mli
new file mode 100644
index 00000000..d10f2c86
--- /dev/null
+++ b/lib/hook.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** This module centralizes the notions of hooks. Hooks are pointers that are to
+ be set at runtime exactly once. *)
+
+type 'a t
+(** The type of hooks containing ['a]. Hooks can only be set. *)
+
+type 'a value
+(** The content part of a hook. *)
+
+val make : ?default:'a -> unit -> ('a value * 'a t)
+(** Create a new hook together with a way to retrieve its runtime value. *)
+
+val get : 'a value -> 'a
+(** Access the content of a hook. If it was not set yet, try to recover the
+ default value if there is one.
+ @raise Assert_failure if undefined. *)
+
+val set : 'a t -> 'a -> unit
+(** Register a hook. Assertion failure if already registered. *)
diff --git a/lib/iStream.ml b/lib/iStream.ml
new file mode 100644
index 00000000..f9351d4b
--- /dev/null
+++ b/lib/iStream.ml
@@ -0,0 +1,90 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type ('a,'r) u =
+| Nil
+| Cons of 'a * 'r
+
+type 'a node = ('a,'a t) u
+
+and 'a t = 'a node Lazy.t
+
+let empty = Lazy.lazy_from_val Nil
+
+let cons x s = Lazy.lazy_from_val (Cons (x, s))
+
+let thunk = Lazy.lazy_from_fun
+
+let rec make_node f s = match f s with
+| Nil -> Nil
+| Cons (x, s) -> Cons (x, make f s)
+
+and make f s = lazy (make_node f s)
+
+let rec force s = match Lazy.force s with
+| Nil -> ()
+| Cons (_, s) -> force s
+
+let force s = force s; s
+
+let is_empty s = match Lazy.force s with
+| Nil -> true
+| Cons (_, _) -> false
+
+let peek = Lazy.force
+
+let rec of_list = function
+| [] -> empty
+| x :: l -> cons x (of_list l)
+
+let rec to_list s = match Lazy.force s with
+| Nil -> []
+| Cons (x, s) -> x :: (to_list s)
+
+let rec iter f s = match Lazy.force s with
+| Nil -> ()
+| Cons (x, s) -> f x; iter f s
+
+let rec map_node f = function
+| Nil -> Nil
+| Cons (x, s) -> Cons (f x, map f s)
+
+and map f s = lazy (map_node f (Lazy.force s))
+
+let rec app_node n1 s2 = match n1 with
+| Nil -> Lazy.force s2
+| Cons (x, s1) -> Cons (x, app s1 s2)
+
+and app s1 s2 = lazy (app_node (Lazy.force s1) s2)
+
+let rec fold f accu s = match Lazy.force s with
+| Nil -> accu
+| Cons (x, s) -> fold f (f accu x) s
+
+let rec map_filter_node f = function
+| Nil -> Nil
+| Cons (x, s) ->
+ begin match f x with
+ | None -> map_filter_node f (Lazy.force s)
+ | Some y -> Cons (y, map_filter f s)
+ end
+
+and map_filter f s = lazy (map_filter_node f (Lazy.force s))
+
+let rec concat_node = function
+| Nil -> Nil
+| Cons (s, sl) -> app_node (Lazy.force s) (concat sl)
+
+and concat (s : 'a t t) =
+ lazy (concat_node (Lazy.force s))
+
+let rec concat_map_node f = function
+| Nil -> Nil
+| Cons (x,s) -> app_node (Lazy.force (f x)) (concat_map f s)
+
+and concat_map f l = lazy (concat_map_node f (Lazy.force l))
diff --git a/lib/iStream.mli b/lib/iStream.mli
new file mode 100644
index 00000000..8cb12af4
--- /dev/null
+++ b/lib/iStream.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** {5 Purely functional streams}
+
+ Contrarily to OCaml module [Stream], these are meant to be used purely
+ functionally. This implies in particular that accessing an element does not
+ discard it. *)
+
+type +'a t
+(** Type of pure streams. *)
+
+type ('a,'r) u =
+| Nil
+| Cons of 'a * 'r
+(** View type to decompose and build streams. *)
+
+(** {6 Constructors} *)
+
+val empty : 'a t
+(** The empty stream. *)
+
+val cons : 'a -> 'a t -> 'a t
+(** Append an element in front of a stream. *)
+
+val thunk : (unit -> ('a,'a t) u) -> 'a t
+(** Internalize the lazyness of a stream. *)
+
+val make : ('a -> ('b, 'a) u) -> 'a -> 'b t
+(** Coiteration constructor. *)
+
+(** {6 Destructors} *)
+
+val is_empty : 'a t -> bool
+(** Whethere a stream is empty. *)
+
+val peek : 'a t -> ('a , 'a t) u
+(** Return the head and the tail of a stream, if any. *)
+
+(** {6 Standard operations}
+
+ All stream-returning functions are lazy. The other ones are eager. *)
+
+val app : 'a t -> 'a t -> 'a t
+(** Append two streams. Not tail-rec. *)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** Mapping of streams. Not tail-rec. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** Iteration over streams. *)
+
+val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+(** Fold over streams. *)
+
+val concat : 'a t t -> 'a t
+(** Appends recursively a stream of streams. *)
+
+val map_filter : ('a -> 'b option) -> 'a t -> 'b t
+(** Mixing [map] and [filter]. Not tail-rec. *)
+
+val concat_map : ('a -> 'b t) -> 'a t -> 'b t
+(** [concat_map f l] is the same as [concat (map f l)]. *)
+
+(** {6 Conversions} *)
+
+val of_list : 'a list -> 'a t
+(** Convert a list into a stream. *)
+
+val to_list : 'a t -> 'a list
+(** Convert a stream into a list. *)
+
+(** {6 Other}*)
+
+val force : 'a t -> 'a t
+(** Forces the whole stream. *)
diff --git a/lib/int.ml b/lib/int.ml
new file mode 100644
index 00000000..d9917657
--- /dev/null
+++ b/lib/int.ml
@@ -0,0 +1,237 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type t = int
+
+external equal : int -> int -> bool = "%eq"
+
+external compare : int -> int -> int = "caml_int_compare"
+
+let hash i = i land 0x3FFFFFFF
+
+module Self =
+struct
+ type t = int
+ let compare = compare
+end
+
+module Set = Set.Make(Self)
+module Map =
+struct
+ include CMap.Make(Self)
+
+ type 'a map = 'a CMap.Make(Self).t
+
+ type 'a _map =
+ | MEmpty
+ | MNode of 'a map * int * 'a * 'a map * int
+
+ let map_prj : 'a map -> 'a _map = Obj.magic
+
+ let rec find i s = match map_prj s with
+ | MEmpty -> raise Not_found
+ | MNode (l, k, v, r, h) ->
+ if i < k then find i l
+ else if i = k then v
+ else find i r
+end
+
+module List = struct
+ let mem = List.memq
+ let assoc = List.assq
+ let mem_assoc = List.mem_assq
+ let remove_assoc = List.remove_assq
+end
+
+let min (i : int) j = if i < j then i else j
+
+(** Utility function *)
+let rec next from upto =
+ if from < upto then next (2 * from + 1) upto
+ else from
+
+
+module PArray =
+struct
+
+ type 'a t = 'a data ref
+ and 'a data =
+ | Root of 'a option array
+ | DSet of int * 'a option * 'a t
+
+ let empty n = ref (Root (Array.make n None))
+
+ let rec rerootk t k = match !t with
+ | Root _ -> k ()
+ | DSet (i, v, t') ->
+ let next () = match !t' with
+ | Root a as n ->
+ let v' = Array.unsafe_get a i in
+ let () = Array.unsafe_set a i v in
+ let () = t := n in
+ let () = t' := DSet (i, v', t) in
+ k ()
+ | DSet _ -> assert false
+ in
+ rerootk t' next
+
+ let reroot t = rerootk t (fun () -> ())
+
+ let get t i =
+ let () = assert (0 <= i) in
+ match !t with
+ | Root a ->
+ if Array.length a <= i then None
+ else Array.unsafe_get a i
+ | DSet _ ->
+ let () = reroot t in
+ match !t with
+ | Root a ->
+ if Array.length a <= i then None
+ else Array.unsafe_get a i
+ | DSet _ -> assert false
+
+ let set t i v =
+ let () = assert (0 <= i) in
+ let () = reroot t in
+ match !t with
+ | DSet _ -> assert false
+ | Root a as n ->
+ let len = Array.length a in
+ if i < len then
+ let old = Array.unsafe_get a i in
+ if old == v then t
+ else
+ let () = Array.unsafe_set a i v in
+ let res = ref n in
+ let () = t := DSet (i, old, res) in
+ res
+ else match v with
+ | None -> t (** Nothing to do! *)
+ | Some _ -> (** we must resize *)
+ let nlen = next len (succ i) in
+ let nlen = min nlen Sys.max_array_length in
+ let () = assert (i < nlen) in
+ let a' = Array.make nlen None in
+ let () = Array.blit a 0 a' 0 len in
+ let () = Array.unsafe_set a' i v in
+ let res = ref (Root a') in
+ let () = t := DSet (i, None, res) in
+ res
+
+end
+
+module PMap =
+struct
+
+ type key = int
+
+ (** Invariants:
+
+ 1. an empty map is always [Empty].
+ 2. the set of the [Map] constructor remembers the present keys.
+ *)
+ type 'a t = Empty | Map of Set.t * 'a PArray.t
+
+ let empty = Empty
+
+ let is_empty = function
+ | Empty -> true
+ | Map _ -> false
+
+ let singleton k x =
+ let len = next 19 (k + 1) in
+ let len = min Sys.max_array_length len in
+ let v = PArray.empty len in
+ let v = PArray.set v k (Some x) in
+ let s = Set.singleton k in
+ Map (s, v)
+
+ let add k x = function
+ | Empty -> singleton k x
+ | Map (s, v) ->
+ let s = match PArray.get v k with
+ | None -> Set.add k s
+ | Some _ -> s
+ in
+ let v = PArray.set v k (Some x) in
+ Map (s, v)
+
+ let remove k = function
+ | Empty -> Empty
+ | Map (s, v) ->
+ let s = Set.remove k s in
+ if Set.is_empty s then Empty
+ else
+ let v = PArray.set v k None in
+ Map (s, v)
+
+ let mem k = function
+ | Empty -> false
+ | Map (_, v) ->
+ match PArray.get v k with
+ | None -> false
+ | Some _ -> true
+
+ let find k = function
+ | Empty -> raise Not_found
+ | Map (_, v) ->
+ match PArray.get v k with
+ | None -> raise Not_found
+ | Some x -> x
+
+ let iter f = function
+ | Empty -> ()
+ | Map (s, v) ->
+ let iter k = match PArray.get v k with
+ | None -> ()
+ | Some x -> f k x
+ in
+ Set.iter iter s
+
+ let fold f m accu = match m with
+ | Empty -> accu
+ | Map (s, v) ->
+ let fold k accu = match PArray.get v k with
+ | None -> accu
+ | Some x -> f k x accu
+ in
+ Set.fold fold s accu
+
+ let exists f m = match m with
+ | Empty -> false
+ | Map (s, v) ->
+ let exists k = match PArray.get v k with
+ | None -> false
+ | Some x -> f k x
+ in
+ Set.exists exists s
+
+ let for_all f m = match m with
+ | Empty -> true
+ | Map (s, v) ->
+ let for_all k = match PArray.get v k with
+ | None -> true
+ | Some x -> f k x
+ in
+ Set.for_all for_all s
+
+ let cast = function
+ | Empty -> Map.empty
+ | Map (s, v) ->
+ let bind k = match PArray.get v k with
+ | None -> assert false
+ | Some x -> x
+ in
+ Map.bind bind s
+
+ let domain = function
+ | Empty -> Set.empty
+ | Map (s, _) -> s
+
+end
diff --git a/lib/int.mli b/lib/int.mli
new file mode 100644
index 00000000..c910bda6
--- /dev/null
+++ b/lib/int.mli
@@ -0,0 +1,79 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** A native integer module with usual utility functions. *)
+
+type t = int
+
+external equal : t -> t -> bool = "%eq"
+
+external compare : t -> t -> int = "caml_int_compare"
+
+val hash : t -> int
+
+module Set : Set.S with type elt = t
+module Map : CMap.ExtS with type key = t and module Set := Set
+
+module List : sig
+ val mem : int -> int list -> bool
+ val assoc : int -> (int * 'a) list -> 'a
+ val mem_assoc : int -> (int * 'a) list -> bool
+ val remove_assoc : int -> (int * 'a) list -> (int * 'a) list
+end
+
+module PArray :
+sig
+ type 'a t
+ (** Persistent, auto-resizable arrays. The [get] and [set] functions never
+ fail whenever the index is between [0] and [Sys.max_array_length - 1]. *)
+ val empty : int -> 'a t
+ (** The empty array, with a given starting size. *)
+ val get : 'a t -> int -> 'a option
+ (** Get a value at the given index. Returns [None] if undefined. *)
+ val set : 'a t -> int -> 'a option -> 'a t
+ (** Set/unset a value at the given index. *)
+end
+
+module PMap :
+sig
+ type key = int
+ type 'a t
+ val empty : 'a t
+ val is_empty : 'a t -> bool
+ val mem : key -> 'a t -> bool
+ val add : key -> 'a -> 'a t -> 'a t
+ val singleton : key -> 'a -> 'a t
+ val remove : key -> 'a t -> 'a t
+(* val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t *)
+(* val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int *)
+(* val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool *)
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val for_all : (key -> 'a -> bool) -> 'a t -> bool
+ val exists : (key -> 'a -> bool) -> 'a t -> bool
+(* val filter : (key -> 'a -> bool) -> 'a t -> 'a t *)
+(* val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t *)
+(* val cardinal : 'a t -> int *)
+(* val bindings : 'a t -> (key * 'a) list *)
+(* val min_binding : 'a t -> key * 'a *)
+(* val max_binding : 'a t -> key * 'a *)
+(* val choose : 'a t -> key * 'a *)
+(* val split : key -> 'a t -> 'a t * 'a option * 'a t *)
+ val find : key -> 'a t -> 'a
+(* val map : ('a -> 'b) -> 'a t -> 'b t *)
+(* val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t *)
+ val domain : 'a t -> Set.t
+ val cast : 'a t -> 'a Map.t
+end
+(** This is a (partial) implementation of a [Map] interface on integers, except
+ that it internally uses persistent arrays. This ensures O(1) accesses in
+ non-backtracking cases. It is thus better suited for zero-starting,
+ contiguous keys, or otherwise a lot of space will be empty. To keep track of
+ the present keys, a binary tree is also used, so that adding a key is
+ still logarithmic. It is therefore essential that most of the operations
+ are accesses and not add/removes. *)
diff --git a/lib/lib.mllib b/lib/lib.mllib
index db79b5c2..f3f6ad8f 100644
--- a/lib/lib.mllib
+++ b/lib/lib.mllib
@@ -1,31 +1,20 @@
-Xml_lexer
-Xml_parser
-Xml_utils
-Pp_control
-Pp
-Compat
-Flags
-Segmenttree
-Unicodetable
-Util
Errors
Bigint
-Hashcons
Dyn
+Segmenttree
+Unicodetable
+Unicode
System
-Envars
-Gmap
-Fset
-Fmap
-Tries
-Gmapl
+CThread
+Spawn
+Trie
Profile
Explore
Predicate
Rtree
Heap
-Option
-Dnet
-Store
Unionfind
-Hashtbl_alt
+Genarg
+Ephemeron
+Future
+RemoteCounter
diff --git a/lib/loc.ml b/lib/loc.ml
new file mode 100644
index 00000000..b62677d4
--- /dev/null
+++ b/lib/loc.ml
@@ -0,0 +1,79 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Locations management *)
+
+
+type t = {
+ fname : string; (** filename *)
+ line_nb : int; (** start line number *)
+ bol_pos : int; (** position of the beginning of start line *)
+ line_nb_last : int; (** end line number *)
+ bol_pos_last : int; (** position of the beginning of end line *)
+ bp : int; (** start position *)
+ ep : int; (** end position *)
+}
+
+let create fname line_nb bol_pos (bp, ep) = {
+ fname = fname; line_nb = line_nb; bol_pos = bol_pos;
+ line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; }
+
+let make_loc (bp, ep) = {
+ fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
+ bp = bp; ep = ep; }
+
+let ghost = {
+ fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
+ bp = 0; ep = 0; }
+
+let is_ghost loc = Pervasives.(=) loc ghost (** FIXME *)
+
+let merge loc1 loc2 =
+ if loc1.bp < loc2.bp then
+ if loc1.ep < loc2.ep then {
+ fname = loc1.fname;
+ line_nb = loc1.line_nb;
+ bol_pos = loc1.bol_pos;
+ line_nb_last = loc2.line_nb_last;
+ bol_pos_last = loc2.bol_pos_last;
+ bp = loc1.bp; ep = loc2.ep; }
+ else loc1
+ else if loc2.ep < loc1.ep then {
+ fname = loc2.fname;
+ line_nb = loc2.line_nb;
+ bol_pos = loc2.bol_pos;
+ line_nb_last = loc1.line_nb_last;
+ bol_pos_last = loc1.bol_pos_last;
+ bp = loc2.bp; ep = loc1.ep; }
+ else loc2
+
+let unloc loc = (loc.bp, loc.ep)
+
+let represent loc = (loc.fname, loc.line_nb, loc.bol_pos, loc.bp, loc.ep)
+
+let dummy_loc = ghost
+let join_loc = merge
+
+(** Located type *)
+
+type 'a located = t * 'a
+let located_fold_left f x (_,a) = f x a
+let located_iter2 f (_,a) (_,b) = f a b
+let down_located f (_,a) = f a
+
+(** Exceptions *)
+
+let location : t Exninfo.t = Exninfo.make ()
+
+let add_loc e loc = Exninfo.add e location loc
+
+let get_loc e = Exninfo.get e location
+
+let raise loc e =
+ let info = Exninfo.add Exninfo.null location loc in
+ Exninfo.iraise (e, info)
diff --git a/lib/loc.mli b/lib/loc.mli
new file mode 100644
index 00000000..7a9a9ffd
--- /dev/null
+++ b/lib/loc.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** {5 Basic types} *)
+
+type t
+
+type 'a located = t * 'a
+(** Embed a location in a type *)
+
+(** {5 Location manipulation} *)
+
+(** This is inherited from CAMPL4/5. *)
+
+val create : string -> int -> int -> (int * int) -> t
+(** Create a location from a filename, a line number, a position of the
+ beginning of the line and a pair of start and end position *)
+
+val unloc : t -> int * int
+(** Return the start and end position of a location *)
+
+val make_loc : int * int -> t
+(** Make a location out of its start and end position *)
+
+val ghost : t
+(** Dummy location *)
+
+val is_ghost : t -> bool
+(** Test whether the location is meaningful *)
+
+val merge : t -> t -> t
+
+val represent : t -> (string * int * int * int * int)
+(** Return the arguments given in [create] *)
+
+(** {5 Located exceptions} *)
+
+val add_loc : Exninfo.info -> t -> Exninfo.info
+(** Adding location to an exception *)
+
+val get_loc : Exninfo.info -> t option
+(** Retrieving the optional location of an exception *)
+
+val raise : t -> exn -> 'a
+(** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *)
+
+(** {5 Location utilities} *)
+
+val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
+val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
+
+val down_located : ('a -> 'b) -> 'a located -> 'b
+(** Projects out a located object *)
+
+(** {5 Backward compatibility} *)
+
+val dummy_loc : t
+(** Same as [ghost] *)
+
+val join_loc : t -> t -> t
+(** Same as [merge] *)
diff --git a/lib/monad.ml b/lib/monad.ml
new file mode 100644
index 00000000..4a52684d
--- /dev/null
+++ b/lib/monad.ml
@@ -0,0 +1,157 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+
+(** Combinators on monadic computations. *)
+
+
+(** A definition of monads, each of the combinators is used in the
+ [Make] functor. *)
+module type Def = sig
+
+ type +'a t
+ val return : 'a -> 'a t
+ val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+ val (>>) : unit t -> 'a t -> 'a t
+ val map : ('a -> 'b) -> 'a t -> 'b t
+
+ (** The monadic laws must hold:
+ - [(x>>=f)>>=g] = [x>>=fun x' -> (f x'>>=g)]
+ - [return a >>= f] = [f a]
+ - [x>>=return] = [x]
+
+ As well as the following identities:
+ - [x >> y] = [x >>= fun () -> y]
+ - [map f x] = [x >>= fun x' -> f x'] *)
+
+end
+
+module type ListS = sig
+
+ type 'a t
+
+ (** [List.map f l] maps [f] on the elements of [l] in left to right
+ order. *)
+ val map : ('a -> 'b t) -> 'a list -> 'b list t
+
+ (** [List.map f l] maps [f] on the elements of [l] in right to left
+ order. *)
+ val map_right : ('a -> 'b t) -> 'a list -> 'b list t
+
+ (** Like the regular [List.fold_right]. The monadic effects are
+ threaded right to left.
+
+ Note: many monads behave poorly with right-to-left order. For
+ instance a failure monad would still have to traverse the
+ whole list in order to fail and failure needs to be propagated
+ through the rest of the list in binds which are now
+ spurious. It is also the worst case for substitution monads
+ (aka free monads), exposing the quadratic behaviour.*)
+ val fold_right : ('a -> 'b -> 'b t) -> 'a list -> 'b -> 'b t
+
+ (** Like the regular [List.fold_left]. The monadic effects are
+ threaded left to right. It is tail-recursive if the [(>>=)]
+ operator calls its second argument in a tail position. *)
+ val fold_left : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t
+
+ (** Like the regular [List.iter]. The monadic effects are threaded
+ left to right. It is tail-recurisve if the [>>] operator calls
+ its second argument in a tail position. *)
+ val iter : ('a -> unit t) -> 'a list -> unit t
+
+
+ (** {6 Two-list iterators} *)
+
+ (** [fold_left2 r f s l1 l2] behaves like {!fold_left} but acts
+ simultaneously on two lists. Runs [r] (presumably an
+ exception-raising computation) if both lists do not have the
+ same length. *)
+ val fold_left2 : 'a t ->
+ ('a -> 'b -> 'c -> 'a t) -> 'a -> 'b list -> 'c list -> 'a t
+
+end
+
+module type S = sig
+
+ include Def
+
+ (** List combinators *)
+ module List : ListS with type 'a t := 'a t
+
+end
+
+
+module Make (M:Def) : S with type +'a t = 'a M.t = struct
+
+ include M
+
+ module List = struct
+
+ (* The combinators are loop-unrolled to spare a some monadic binds
+ (it is a common optimisation to treat the last of a list of
+ bind specially) and hopefully gain some efficiency using fewer
+ jump. *)
+
+ let rec map f = function
+ | [] -> return []
+ | [a] ->
+ M.map (fun a' -> [a']) (f a)
+ | a::b::l ->
+ f a >>= fun a' ->
+ f b >>= fun b' ->
+ M.map (fun l' -> a'::b'::l') (map f l)
+
+ let rec map_right f = function
+ | [] -> return []
+ | [a] ->
+ M.map (fun a' -> [a']) (f a)
+ | a::b::l ->
+ map f l >>= fun l' ->
+ f b >>= fun b' ->
+ M.map (fun a' -> a'::b'::l') (f a)
+
+ let rec fold_right f l x =
+ match l with
+ | [] -> return x
+ | [a] -> f a x
+ | a::b::l ->
+ fold_right f l x >>= fun acc ->
+ f b acc >>= fun acc ->
+ f a acc
+
+ let rec fold_left f x = function
+ | [] -> return x
+ | [a] -> f x a
+ | a::b::l ->
+ f x a >>= fun x' ->
+ f x' b >>= fun x'' ->
+ fold_left f x'' l
+
+ let rec iter f = function
+ | [] -> return ()
+ | [a] -> f a
+ | a::b::l -> f a >> f b >> iter f l
+
+
+
+ let rec fold_left2 r f x l1 l2 =
+ match l1,l2 with
+ | [] , [] -> return x
+ | [a] , [b] -> f x a b
+ | a1::a2::l1 , b1::b2::l2 ->
+ f x a1 b1 >>= fun x' ->
+ f x' a2 b2 >>= fun x'' ->
+ fold_left2 r f x'' l1 l2
+ | _ , _ -> r
+
+ end
+
+end
+
+
+
diff --git a/lib/monad.mli b/lib/monad.mli
new file mode 100644
index 00000000..c8655efa
--- /dev/null
+++ b/lib/monad.mli
@@ -0,0 +1,90 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+
+(** Combinators on monadic computations. *)
+
+
+(** A definition of monads, each of the combinators is used in the
+ [Make] functor. *)
+module type Def = sig
+
+ type +'a t
+ val return : 'a -> 'a t
+ val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+ val (>>) : unit t -> 'a t -> 'a t
+ val map : ('a -> 'b) -> 'a t -> 'b t
+
+(** The monadic laws must hold:
+ - [(x>>=f)>>=g] = [x>>=fun x' -> (f x'>>=g)]
+ - [return a >>= f] = [f a]
+ - [x>>=return] = [x]
+
+ As well as the following identities:
+ - [x >> y] = [x >>= fun () -> y]
+ - [map f x] = [x >>= fun x' -> f x'] *)
+
+end
+
+
+(** List combinators *)
+module type ListS = sig
+
+ type 'a t
+
+ (** [List.map f l] maps [f] on the elements of [l] in left to right
+ order. *)
+ val map : ('a -> 'b t) -> 'a list -> 'b list t
+
+ (** [List.map f l] maps [f] on the elements of [l] in right to left
+ order. *)
+ val map_right : ('a -> 'b t) -> 'a list -> 'b list t
+
+ (** Like the regular [List.fold_right]. The monadic effects are
+ threaded right to left.
+
+ Note: many monads behave poorly with right-to-left order. For
+ instance a failure monad would still have to traverse the
+ whole list in order to fail and failure needs to be propagated
+ through the rest of the list in binds which are now
+ spurious. It is also the worst case for substitution monads
+ (aka free monads), exposing the quadratic behaviour.*)
+ val fold_right : ('a -> 'b -> 'b t) -> 'a list -> 'b -> 'b t
+
+ (** Like the regular [List.fold_left]. The monadic effects are
+ threaded left to right. It is tail-recursive if the [(>>=)]
+ operator calls its second argument in a tail position. *)
+ val fold_left : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t
+
+ (** Like the regular [List.iter]. The monadic effects are threaded
+ left to right. It is tail-recurisve if the [>>] operator calls
+ its second argument in a tail position. *)
+ val iter : ('a -> unit t) -> 'a list -> unit t
+
+
+ (** {6 Two-list iterators} *)
+
+ (** [fold_left2 r f s l1 l2] behaves like {!fold_left} but acts
+ simultaneously on two lists. Runs [r] (presumably an
+ exception-raising computation) if both lists do not have the
+ same length. *)
+ val fold_left2 : 'a t ->
+ ('a -> 'b -> 'c -> 'a t) -> 'a -> 'b list -> 'c list -> 'a t
+
+end
+
+module type S = sig
+
+ include Def
+
+ module List : ListS with type 'a t := 'a t
+
+end
+
+(** Expands the monadic definition to extra combinators. *)
+module Make (M:Def) : S with type +'a t = 'a M.t
diff --git a/lib/option.ml b/lib/option.ml
index d6df7063..9ea1a769 100644
--- a/lib/option.ml
+++ b/lib/option.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -19,6 +19,26 @@ let has_some = function
| None -> false
| _ -> true
+let is_empty = function
+| None -> true
+| Some _ -> false
+
+(** Lifting equality onto option types. *)
+let equal f x y = match x, y with
+| None, None -> true
+| Some x, Some y -> f x y
+| _, _ -> false
+
+let compare f x y = match x, y with
+| None, None -> 0
+| Some x, Some y -> f x y
+| None, Some _ -> -1
+| Some _, None -> 1
+
+let hash f = function
+| None -> 0
+| Some x -> f x
+
exception IsNone
(** [get x] returns [y] where [x] is [Some y]. It raises IsNone
@@ -44,6 +64,14 @@ let flatten = function
| _ -> None
+(** [append x y] is the first element of the concatenation of [x] and
+ [y] seen as lists. *)
+let append o1 o2 =
+ match o1 with
+ | Some _ -> o1
+ | None -> o2
+
+
(** {6 "Iterators"} ***)
(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing
@@ -153,21 +181,11 @@ module List =
let rec flatten = function
| x::l -> cons x (flatten l)
| [] -> []
-end
-
+ let rec find f = function
+ |[] -> None
+ |h :: t -> match f h with
+ |None -> find f t
+ |x -> x
-(** {6 Miscelaneous Primitives} *)
-
-module Misc =
- struct
- (** [Misc.compare f x y] lifts the equality predicate [f] to
- option types. That is, if both [x] and [y] are [None] then
- it returns [true], if they are bothe [Some _] then
- [f] is called. Otherwise it returns [false]. *)
- let compare f x y =
- match x,y with
- | None, None -> true
- | Some z, Some w -> f z w
- | _,_ -> false
end
diff --git a/lib/option.mli b/lib/option.mli
index 121d6500..d9ad0e11 100644
--- a/lib/option.mli
+++ b/lib/option.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -13,11 +13,26 @@
they actually are similar considering ['a option] as a type
of lists with at most one element. *)
+exception IsNone
+
(** [has_some x] is [true] if [x] is of the form [Some y] and [false]
otherwise. *)
val has_some : 'a option -> bool
-exception IsNone
+(** Negation of [has_some] *)
+val is_empty : 'a option -> bool
+
+(** [equal f x y] lifts the equality predicate [f] to
+ option types. That is, if both [x] and [y] are [None] then
+ it returns [true], if they are both [Some _] then
+ [f] is called. Otherwise it returns [false]. *)
+val equal : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool
+
+(** Same as [equal], but with comparison. *)
+val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int
+
+(** Lift a hash to option types. *)
+val hash : ('a -> int) -> 'a option -> int
(** [get x] returns [y] where [x] is [Some y]. It raises IsNone
if [x] equals [None]. *)
@@ -32,6 +47,12 @@ val init : bool -> 'a -> 'a option
(** [flatten x] is [Some y] if [x] is [Some (Some y)] and [None] otherwise. *)
val flatten : 'a option option -> 'a option
+(** [append x y] is the first element of the concatenation of [x] and
+ [y] seen as lists. In other words, [append (Some a) y] is [Some
+ a], [append None (Some b)] is [Some b], and [append None None] is
+ [None]. *)
+val append : 'a option -> 'a option -> 'a option
+
(** {6 "Iterators"} ***)
@@ -67,7 +88,7 @@ val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
(** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *)
val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option
-(** [cata e f x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *)
+(** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *)
val cata : ('a -> 'b) -> 'b -> 'a option -> 'b
(** {6 More Specific Operations} ***)
@@ -100,16 +121,6 @@ module List : sig
(** [List.flatten l] is the list of all the [y]s such that [l] contains
[Some y] (in the same order). *)
val flatten : 'a option list -> 'a list
-end
-
-(** {6 Miscelaneous Primitives} *)
-
-module Misc : sig
- (** [Misc.compare f x y] lifts the equality predicate [f] to
- option types. That is, if both [x] and [y] are [None] then
- it returns [true], if they are bothe [Some _] then
- [f] is called. Otherwise it returns [false]. *)
- val compare : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool
+ val find : ('a -> 'b option) -> 'a list -> 'b option
end
-
diff --git a/lib/pp.ml b/lib/pp.ml
new file mode 100644
index 00000000..234d2344
--- /dev/null
+++ b/lib/pp.ml
@@ -0,0 +1,591 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module Glue : sig
+
+ (* A left associative glue implements efficient glue operator
+ when used as left associative. If glue is denoted ++ then
+
+ a ++ b ++ c ++ d = ((a ++ b) ++ c) ++ d = [d] @ ([c] @ ([b] @ [a]))
+
+ I.e. if the short list is the second argument
+ *)
+ type 'a t
+
+ val atom : 'a -> 'a t
+ val glue : 'a t -> 'a t -> 'a t
+ val empty : 'a t
+ val is_empty : 'a t -> bool
+ val iter : ('a -> unit) -> 'a t -> unit
+ val map : ('a -> 'b) -> 'a t -> 'b t
+
+end = struct
+
+ type 'a t = 'a list
+
+ let atom x = [x]
+ let glue x y = y @ x
+ let empty = []
+ let is_empty x = x = []
+
+ let iter f g = List.iter f (List.rev g)
+ let map = List.map
+end
+
+module Tag :
+sig
+ type t
+ type 'a key
+ val create : string -> 'a key
+ val inj : 'a -> 'a key -> t
+ val prj : t -> 'a key -> 'a option
+end =
+struct
+ (** See module {Dyn} for more details. *)
+
+ type t = int * Obj.t
+
+ type 'a key = int
+
+ let dyntab = ref (Int.Map.empty : string Int.Map.t)
+
+ let create (s : string) =
+ let hash = Hashtbl.hash s in
+ let () = assert (not (Int.Map.mem hash !dyntab)) in
+ let () = dyntab := Int.Map.add hash s !dyntab in
+ hash
+
+ let inj x h = (h, Obj.repr x)
+
+ let prj (nh, rv) h =
+ if Int.equal h nh then Some (Obj.magic rv)
+ else None
+
+end
+
+open Pp_control
+
+(* This should not be used outside of this file. Use
+ Flags.print_emacs instead. This one is updated when reading
+ command line options. This was the only way to make [Pp] depend on
+ an option without creating a circularity: [Flags] -> [Util] ->
+ [Pp] -> [Flags] *)
+let print_emacs = ref false
+
+(* The different kinds of blocks are:
+ \begin{description}
+ \item[hbox:] Horizontal block no line breaking;
+ \item[vbox:] Vertical block each break leads to a new line;
+ \item[hvbox:] Horizontal-vertical block: same as vbox, except if
+ this block is small enough to fit on a single line
+ \item[hovbox:] Horizontal or Vertical block: breaks lead to new line
+ only when necessary to print the content of the block
+ \item[tbox:] Tabulation block: go to tabulation marks and no line breaking
+ (except if no mark yet on the reste of the line)
+ \end{description}
+ *)
+
+let comments = ref []
+
+let rec split_com comacc acc pos = function
+ [] -> comments := List.rev acc; comacc
+ | ((b,e),c as com)::coms ->
+ (* Take all comments that terminates before pos, or begin exactly
+ at pos (used to print comments attached after an expression) *)
+ if e<=pos || pos=b then split_com (c::comacc) acc pos coms
+ else split_com comacc (com::acc) pos coms
+
+
+type block_type =
+ | Pp_hbox of int
+ | Pp_vbox of int
+ | Pp_hvbox of int
+ | Pp_hovbox of int
+ | Pp_tbox
+
+type str_token =
+| Str_def of string
+| Str_len of string * int (** provided length *)
+
+type 'a ppcmd_token =
+ | Ppcmd_print of 'a
+ | Ppcmd_box of block_type * ('a ppcmd_token Glue.t)
+ | Ppcmd_print_break of int * int
+ | Ppcmd_set_tab
+ | Ppcmd_print_tbreak of int * int
+ | Ppcmd_white_space of int
+ | Ppcmd_force_newline
+ | Ppcmd_print_if_broken
+ | Ppcmd_open_box of block_type
+ | Ppcmd_close_box
+ | Ppcmd_close_tbox
+ | Ppcmd_comment of int
+ | Ppcmd_open_tag of Tag.t
+ | Ppcmd_close_tag
+
+type 'a ppdir_token =
+ | Ppdir_ppcmds of 'a ppcmd_token Glue.t
+ | Ppdir_print_newline
+ | Ppdir_print_flush
+
+type ppcmd = str_token ppcmd_token
+
+type std_ppcmds = ppcmd Glue.t
+
+type 'a ppdirs = 'a ppdir_token Glue.t
+
+let (++) = Glue.glue
+
+let app = Glue.glue
+
+let is_empty g = Glue.is_empty g
+
+let rewrite f p =
+ let strtoken = function
+ | Str_len (s, n) ->
+ let s' = f s in
+ Str_len (s', String.length s')
+ | Str_def s ->
+ Str_def (f s)
+ in
+ let rec ppcmd_token = function
+ | Ppcmd_print x -> Ppcmd_print (strtoken x)
+ | Ppcmd_box (bt, g) -> Ppcmd_box (bt, Glue.map ppcmd_token g)
+ | p -> p
+ in
+ Glue.map ppcmd_token p
+
+(* Compute length of an UTF-8 encoded string
+ Rem 1 : utf8_length <= String.length (equal if pure ascii)
+ Rem 2 : if used for an iso8859_1 encoded string, the result is
+ wrong in very rare cases. Such a wrong case corresponds to any
+ sequence of a character in range 192..253 immediately followed by a
+ character in range 128..191 (typical case in french is "déçu" which
+ is counted 3 instead of 4); then no real harm to use always
+ utf8_length even if using an iso8859_1 encoding *)
+
+let utf8_length s =
+ let len = String.length s
+ and cnt = ref 0
+ and nc = ref 0
+ and p = ref 0 in
+ while !p < len do
+ begin
+ match s.[!p] with
+ | '\000'..'\127' -> nc := 0 (* ascii char *)
+ | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *)
+ | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *)
+ | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *)
+ | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *)
+ | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *)
+ | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *)
+ | '\254'..'\255' -> nc := 0 (* invalid byte *)
+ end ;
+ incr p ;
+ while !p < len && !nc > 0 do
+ match s.[!p] with
+ | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc
+ | _ (* not a continuation byte *) -> nc := 0
+ done ;
+ incr cnt
+ done ;
+ !cnt
+
+(* formatting commands *)
+let str s = Glue.atom(Ppcmd_print (Str_def s))
+let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i)))
+let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b))
+let tbrk (a,b) = Glue.atom(Ppcmd_print_tbreak (a,b))
+let tab () = Glue.atom(Ppcmd_set_tab)
+let fnl () = Glue.atom(Ppcmd_force_newline)
+let pifb () = Glue.atom(Ppcmd_print_if_broken)
+let ws n = Glue.atom(Ppcmd_white_space n)
+let comment n = Glue.atom(Ppcmd_comment n)
+
+(* derived commands *)
+let mt () = Glue.empty
+let spc () = Glue.atom(Ppcmd_print_break (1,0))
+let cut () = Glue.atom(Ppcmd_print_break (0,0))
+let align () = Glue.atom(Ppcmd_print_break (0,0))
+let int n = str (string_of_int n)
+let real r = str (string_of_float r)
+let bool b = str (string_of_bool b)
+let strbrk s =
+ let rec aux p n =
+ if n < String.length s then
+ if s.[n] = ' ' then
+ if p = n then spc() :: aux (n+1) (n+1)
+ else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1)
+ else aux p (n + 1)
+ else if p = n then [] else [str (String.sub s p (n-p))]
+ in List.fold_left (++) Glue.empty (aux 0 0)
+
+let ismt = is_empty
+
+(* boxing commands *)
+let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s))
+let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s))
+let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s))
+let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s))
+let t s = Glue.atom(Ppcmd_box(Pp_tbox,s))
+
+(* Opening and closing of boxes *)
+let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n))
+let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n))
+let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n))
+let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n))
+let tb () = Glue.atom(Ppcmd_open_box Pp_tbox)
+let close () = Glue.atom(Ppcmd_close_box)
+let tclose () = Glue.atom(Ppcmd_close_tbox)
+
+(* Opening and closed of tags *)
+let open_tag t = Glue.atom(Ppcmd_open_tag t)
+let close_tag () = Glue.atom(Ppcmd_close_tag)
+let tag t s = open_tag t ++ s ++ close_tag ()
+let eval_ppcmds l = l
+
+(* In new syntax only double quote char is escaped by repeating it *)
+let escape_string s =
+ let rec escape_at s i =
+ if i<0 then s
+ else if s.[i] == '"' then
+ let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in
+ escape_at s' (i-1)
+ else escape_at s (i-1) in
+ escape_at s (String.length s - 1)
+
+let qstring s = str ("\""^escape_string s^"\"")
+let qs = qstring
+let quote s = h 0 (str "\"" ++ s ++ str "\"")
+
+(* This flag tells if the last printed comment ends with a newline, to
+ avoid empty lines *)
+let com_eol = ref false
+
+let com_brk ft = com_eol := false
+let com_if ft f =
+ if !com_eol then (com_eol := false; Format.pp_force_newline ft ())
+ else Lazy.force f
+
+let rec pr_com ft s =
+ let (s1,os) =
+ try
+ let n = String.index s '\n' in
+ String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1))
+ with Not_found -> s,None in
+ com_if ft (Lazy.lazy_from_val());
+(* let s1 =
+ if String.length s1 <> 0 && s1.[0] = ' ' then
+ (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1))
+ else s1 in*)
+ Format.pp_print_as ft (utf8_length s1) s1;
+ match os with
+ Some s2 ->
+ if Int.equal (String.length s2) 0 then (com_eol := true)
+ else
+ (Format.pp_force_newline ft (); pr_com ft s2)
+ | None -> ()
+
+type tag_handler = Tag.t -> Format.tag
+
+(* pretty printing functions *)
+let pp_dirs ?pp_tag ft =
+ let pp_open_box = function
+ | Pp_hbox n -> Format.pp_open_hbox ft ()
+ | Pp_vbox n -> Format.pp_open_vbox ft n
+ | Pp_hvbox n -> Format.pp_open_hvbox ft n
+ | Pp_hovbox n -> Format.pp_open_hovbox ft n
+ | Pp_tbox -> Format.pp_open_tbox ft ()
+ in
+ let rec pp_cmd = function
+ | Ppcmd_print tok ->
+ begin match tok with
+ | Str_def s ->
+ let n = utf8_length s in
+ com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
+ | Str_len (s, n) ->
+ com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
+ end
+ | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *)
+ com_if ft (Lazy.lazy_from_val());
+ pp_open_box bty ;
+ if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss;
+ Format.pp_close_box ft ()
+ | Ppcmd_open_box bty -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty
+ | Ppcmd_close_box -> Format.pp_close_box ft ()
+ | Ppcmd_close_tbox -> Format.pp_close_tbox ft ()
+ | Ppcmd_white_space n ->
+ com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0))
+ | Ppcmd_print_break(m,n) ->
+ com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n))
+ | Ppcmd_set_tab -> Format.pp_set_tab ft ()
+ | Ppcmd_print_tbreak(m,n) ->
+ com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n))
+ | Ppcmd_force_newline ->
+ com_brk ft; Format.pp_force_newline ft ()
+ | Ppcmd_print_if_broken ->
+ com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ()))
+ | Ppcmd_comment i ->
+ let coms = split_com [] [] i !comments in
+(* Format.pp_open_hvbox ft 0;*)
+ List.iter (pr_com ft) coms(*;
+ Format.pp_close_box ft ()*)
+ | Ppcmd_open_tag tag ->
+ begin match pp_tag with
+ | None -> ()
+ | Some f -> Format.pp_open_tag ft (f tag)
+ end
+ | Ppcmd_close_tag ->
+ begin match pp_tag with
+ | None -> ()
+ | Some _ -> Format.pp_close_tag ft ()
+ end
+ in
+ let pp_dir = function
+ | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream
+ | Ppdir_print_newline ->
+ com_brk ft; Format.pp_print_newline ft ()
+ | Ppdir_print_flush -> Format.pp_print_flush ft ()
+ in
+ fun (dirstream : _ ppdirs) ->
+ try
+ Glue.iter pp_dir dirstream; com_brk ft
+ with reraise ->
+ let reraise = Backtrace.add_backtrace reraise in
+ let () = Format.pp_print_flush ft () in
+ Exninfo.iraise reraise
+
+
+
+(* pretty print on stdout and stderr *)
+
+(* Special chars for emacs, to detect warnings inside goal output *)
+let emacs_quote_start = String.make 1 (Char.chr 254)
+let emacs_quote_end = String.make 1 (Char.chr 255)
+
+let emacs_quote_info_start = "<infomsg>"
+let emacs_quote_info_end = "</infomsg>"
+
+let emacs_quote g =
+ if !print_emacs then str emacs_quote_start ++ hov 0 g ++ str emacs_quote_end
+ else hov 0 g
+
+let emacs_quote_info g =
+ if !print_emacs then str emacs_quote_info_start++fnl() ++ hov 0 g ++ str emacs_quote_info_end
+ else hov 0 g
+
+
+(* pretty printing functions WITHOUT FLUSH *)
+let pp_with ?pp_tag ft strm =
+ pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm))
+
+let ppnl_with ft strm =
+ pp_dirs ft (Glue.atom (Ppdir_ppcmds (strm ++ fnl ())))
+
+let pp_flush_with ft = Format.pp_print_flush ft
+
+(* pretty printing functions WITH FLUSH *)
+let msg_with ft strm =
+ pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush))
+
+let msgnl_with ft strm =
+ pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_newline))
+
+(* pretty printing functions WITHOUT FLUSH *)
+let pp x = pp_with !std_ft x
+let ppnl x = ppnl_with !std_ft x
+let pperr x = pp_with !err_ft x
+let pperrnl x = ppnl_with !err_ft x
+let message s = ppnl (str s)
+let pp_flush x = Format.pp_print_flush !std_ft x
+let pperr_flush x = Format.pp_print_flush !err_ft x
+let flush_all () =
+ flush stderr; flush stdout; pp_flush (); pperr_flush ()
+
+(* pretty printing functions WITH FLUSH *)
+let msg x = msg_with !std_ft x
+let msgnl x = msgnl_with !std_ft x
+let msgerr x = msg_with !err_ft x
+let msgerrnl x = msgnl_with !err_ft x
+
+(* Logging management *)
+
+type message_level = Feedback.message_level =
+ | Debug of string
+ | Info
+ | Notice
+ | Warning
+ | Error
+
+type message = Feedback.message = {
+ message_level : message_level;
+ message_content : string;
+}
+
+let of_message = Feedback.of_message
+let to_message = Feedback.to_message
+let is_message = Feedback.is_message
+
+type logger = message_level -> std_ppcmds -> unit
+
+let make_body info s =
+ emacs_quote (hov 0 (info ++ spc () ++ s))
+
+let debugbody strm = hov 0 (str "Debug:" ++ spc () ++ strm)
+let warnbody strm = make_body (str "Warning:") strm
+let errorbody strm = make_body (str "Error:") strm
+let infobody strm = emacs_quote_info strm
+
+let std_logger ~id:_ level msg = match level with
+| Debug _ -> msgnl (debugbody msg)
+| Info -> msgnl (hov 0 msg)
+| Notice -> msgnl msg
+| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody msg)) ()
+| Error -> msgnl_with !err_ft (errorbody msg)
+
+let emacs_logger ~id:_ level mesg = match level with
+| Debug _ -> msgnl (debugbody mesg)
+| Info -> msgnl (infobody mesg)
+| Notice -> msgnl mesg
+| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody mesg)) ()
+| Error -> msgnl_with !err_ft (errorbody mesg)
+
+let logger = ref std_logger
+
+let make_pp_emacs() = print_emacs:=true; logger:=emacs_logger
+let make_pp_nonemacs() = print_emacs:=false; logger := std_logger
+
+
+let feedback_id = ref (Feedback.Edit 0)
+let feedback_route = ref Feedback.default_route
+
+(* If mixing some output and a goal display, please use msg_warning,
+ so that interfaces (proofgeneral for example) can easily dispatch
+ them to different windows. *)
+
+let msg_info x = !logger ~id:!feedback_id Info x
+let msg_notice x = !logger ~id:!feedback_id Notice x
+let msg_warning x = !logger ~id:!feedback_id Warning x
+let msg_error x = !logger ~id:!feedback_id Error x
+let msg_debug x = !logger ~id:!feedback_id (Debug "_") x
+
+let set_logger l = logger := (fun ~id:_ lvl msg -> l lvl msg)
+
+let std_logger lvl msg = std_logger ~id:!feedback_id lvl msg
+
+(** Feedback *)
+
+let feeder = ref ignore
+let set_id_for_feedback ?(route=Feedback.default_route) i =
+ feedback_id := i; feedback_route := route
+let feedback ?state_id ?edit_id ?route what =
+ !feeder {
+ Feedback.contents = what;
+ Feedback.route = Option.default !feedback_route route;
+ Feedback.id =
+ match state_id, edit_id with
+ | Some id, _ -> Feedback.State id
+ | None, Some eid -> Feedback.Edit eid
+ | None, None -> !feedback_id;
+ }
+let set_feeder f = feeder := f
+let get_id_for_feedback () = !feedback_id, !feedback_route
+
+(** Utility *)
+
+let string_of_ppcmds c =
+ msg_with Format.str_formatter c;
+ Format.flush_str_formatter ()
+
+let log_via_feedback () = logger := (fun ~id lvl msg ->
+ !feeder {
+ Feedback.contents = Feedback.Message {
+ message_level = lvl;
+ message_content = string_of_ppcmds msg };
+ Feedback.route = !feedback_route;
+ Feedback.id = id })
+
+(* Copy paste from Util *)
+
+let pr_comma () = str "," ++ spc ()
+let pr_semicolon () = str ";" ++ spc ()
+let pr_bar () = str "|" ++ spc ()
+let pr_arg pr x = spc () ++ pr x
+let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x
+let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x
+
+let pr_nth n =
+ int n ++ str (match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th")
+
+(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
+
+let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Glue.empty l
+
+(* unlike all other functions below, [prlist] works lazily.
+ if a strict behavior is needed, use [prlist_strict] instead.
+ evaluation is done from left to right. *)
+
+let prlist_sep_lastsep no_empty sep lastsep elem =
+ let rec start = function
+ |[] -> mt ()
+ |[e] -> elem e
+ |h::t -> let e = elem h in
+ if no_empty && ismt e then start t else
+ let rec aux = function
+ |[] -> mt ()
+ |h::t ->
+ let e = elem h and r = aux t in
+ if no_empty && ismt e then r else
+ if ismt r
+ then let s = lastsep () in s ++ e
+ else let s = sep () in s ++ e ++ r
+ in let r = aux t in e ++ r
+ in start
+
+let prlist_strict pr l = prlist_sep_lastsep true mt mt pr l
+(* [prlist_with_sep sep pr [a ; ... ; c]] outputs
+ [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
+let prlist_with_sep sep pr l = prlist_sep_lastsep false sep sep pr l
+(* Print sequence of objects separated by space (unless an element is empty) *)
+let pr_sequence pr l = prlist_sep_lastsep true spc spc pr l
+(* [pr_enum pr [a ; b ; ... ; c]] outputs
+ [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *)
+let pr_enum pr l = prlist_sep_lastsep true pr_comma (fun () -> str " and" ++ spc ()) pr l
+
+let pr_vertical_list pr = function
+ | [] -> str "none" ++ fnl ()
+ | l -> fnl () ++ str " " ++ hov 0 (prlist_with_sep fnl pr l) ++ fnl ()
+
+(* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs
+ [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *)
+
+let prvecti_with_sep sep elem v =
+ let rec pr i =
+ if Int.equal i 0 then
+ elem 0 v.(0)
+ else
+ let r = pr (i-1) and s = sep () and e = elem i v.(i) in
+ r ++ s ++ e
+ in
+ let n = Array.length v in
+ if Int.equal n 0 then mt () else pr (n - 1)
+
+(* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *)
+
+let prvecti elem v = prvecti_with_sep mt elem v
+
+(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs
+ [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
+
+let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v
+
+(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *)
+
+let prvect elem v = prvect_with_sep mt elem v
+
+let surround p = hov 1 (str"(" ++ p ++ str")")
diff --git a/lib/pp.ml4 b/lib/pp.ml4
deleted file mode 100644
index f13a3d16..00000000
--- a/lib/pp.ml4
+++ /dev/null
@@ -1,351 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Pp_control
-
-(* This should not be used outside of this file. Use
- Flags.print_emacs instead. This one is updated when reading
- command line options. This was the only way to make [Pp] depend on
- an option without creating a circularity: [Flags. -> [Util] ->
- [Pp] -> [Flags. *)
-let print_emacs = ref false
-let make_pp_emacs() = print_emacs:=true
-let make_pp_nonemacs() = print_emacs:=false
-
-(* The different kinds of blocks are:
- \begin{description}
- \item[hbox:] Horizontal block no line breaking;
- \item[vbox:] Vertical block each break leads to a new line;
- \item[hvbox:] Horizontal-vertical block: same as vbox, except if
- this block is small enough to fit on a single line
- \item[hovbox:] Horizontal or Vertical block: breaks lead to new line
- only when necessary to print the content of the block
- \item[tbox:] Tabulation block: go to tabulation marks and no line breaking
- (except if no mark yet on the reste of the line)
- \end{description}
- *)
-
-let comments = ref []
-
-let rec split_com comacc acc pos = function
- [] -> comments := List.rev acc; comacc
- | ((b,e),c as com)::coms ->
- (* Take all comments that terminates before pos, or begin exactly
- at pos (used to print comments attached after an expression) *)
- if e<=pos || pos=b then split_com (c::comacc) acc pos coms
- else split_com comacc (com::acc) pos coms
-
-
-type block_type =
- | Pp_hbox of int
- | Pp_vbox of int
- | Pp_hvbox of int
- | Pp_hovbox of int
- | Pp_tbox
-
-type 'a ppcmd_token =
- | Ppcmd_print of 'a
- | Ppcmd_box of block_type * ('a ppcmd_token Stream.t)
- | Ppcmd_print_break of int * int
- | Ppcmd_set_tab
- | Ppcmd_print_tbreak of int * int
- | Ppcmd_white_space of int
- | Ppcmd_force_newline
- | Ppcmd_print_if_broken
- | Ppcmd_open_box of block_type
- | Ppcmd_close_box
- | Ppcmd_close_tbox
- | Ppcmd_comment of int
-
-type 'a ppdir_token =
- | Ppdir_ppcmds of 'a ppcmd_token Stream.t
- | Ppdir_print_newline
- | Ppdir_print_flush
-
-type ppcmd = (int*string) ppcmd_token
-
-type std_ppcmds = ppcmd Stream.t
-
-type 'a ppdirs = 'a ppdir_token Stream.t
-
-(* Compute length of an UTF-8 encoded string
- Rem 1 : utf8_length <= String.length (equal if pure ascii)
- Rem 2 : if used for an iso8859_1 encoded string, the result is
- wrong in very rare cases. Such a wrong case corresponds to any
- sequence of a character in range 192..253 immediately followed by a
- character in range 128..191 (typical case in french is "déçu" which
- is counted 3 instead of 4); then no real harm to use always
- utf8_length even if using an iso8859_1 encoding *)
-
-let utf8_length s =
- let len = String.length s
- and cnt = ref 0
- and nc = ref 0
- and p = ref 0 in
- while !p < len do
- begin
- match s.[!p] with
- | '\000'..'\127' -> nc := 0 (* ascii char *)
- | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *)
- | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *)
- | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *)
- | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *)
- | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *)
- | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *)
- | '\254'..'\255' -> nc := 0 (* invalid byte *)
- end ;
- incr p ;
- while !p < len && !nc > 0 do
- match s.[!p] with
- | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc
- | _ (* not a continuation byte *) -> nc := 0
- done ;
- incr cnt
- done ;
- !cnt
-
-(* formatting commands *)
-let str s = [< 'Ppcmd_print (utf8_length s,s) >]
-let stras (i,s) = [< 'Ppcmd_print (i,s) >]
-let brk (a,b) = [< 'Ppcmd_print_break (a,b) >]
-let tbrk (a,b) = [< 'Ppcmd_print_tbreak (a,b) >]
-let tab () = [< 'Ppcmd_set_tab >]
-let fnl () = [< 'Ppcmd_force_newline >]
-let pifb () = [< 'Ppcmd_print_if_broken >]
-let ws n = [< 'Ppcmd_white_space n >]
-let comment n = [< ' Ppcmd_comment n >]
-
-(* derived commands *)
-let mt () = [< >]
-let spc () = [< 'Ppcmd_print_break (1,0) >]
-let cut () = [< 'Ppcmd_print_break (0,0) >]
-let align () = [< 'Ppcmd_print_break (0,0) >]
-let int n = str (string_of_int n)
-let real r = str (string_of_float r)
-let bool b = str (string_of_bool b)
-let strbrk s =
- let rec aux p n =
- if n < String.length s then
- if s.[n] = ' ' then
- if p=n then [< spc (); aux (n+1) (n+1) >]
- else [< str (String.sub s p (n-p)); spc (); aux (n+1) (n+1) >]
- else aux p (n+1)
- else if p=n then [< >] else [< str (String.sub s p (n-p)) >]
- in aux 0 0
-
-let ismt s = try let _ = Stream.empty s in true with Stream.Failure -> false
-
-(* boxing commands *)
-let h n s = [< 'Ppcmd_box(Pp_hbox n,s) >]
-let v n s = [< 'Ppcmd_box(Pp_vbox n,s) >]
-let hv n s = [< 'Ppcmd_box(Pp_hvbox n,s) >]
-let hov n s = [< 'Ppcmd_box(Pp_hovbox n,s) >]
-let t s = [< 'Ppcmd_box(Pp_tbox,s) >]
-
-(* Opening and closing of boxes *)
-let hb n = [< 'Ppcmd_open_box(Pp_hbox n) >]
-let vb n = [< 'Ppcmd_open_box(Pp_vbox n) >]
-let hvb n = [< 'Ppcmd_open_box(Pp_hvbox n) >]
-let hovb n = [< 'Ppcmd_open_box(Pp_hovbox n) >]
-let tb () = [< 'Ppcmd_open_box Pp_tbox >]
-let close () = [< 'Ppcmd_close_box >]
-let tclose () = [< 'Ppcmd_close_tbox >]
-
-let (++) = Stream.iapp
-
-let rec eval_ppcmds l =
- let rec aux l =
- try
- let a = match Stream.next l with
- | Ppcmd_box (b,s) -> Ppcmd_box (b,eval_ppcmds s)
- | a -> a in
- let rest = aux l in
- a :: rest
- with Stream.Failure -> [] in
- Stream.of_list (aux l)
-
-(* In new syntax only double quote char is escaped by repeating it *)
-let rec escape_string s =
- let rec escape_at s i =
- if i<0 then s
- else if s.[i] == '"' then
- let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in
- escape_at s' (i-1)
- else escape_at s (i-1) in
- escape_at s (String.length s - 1)
-
-let qstring s = str ("\""^escape_string s^"\"")
-let qs = qstring
-let quote s = h 0 (str "\"" ++ s ++ str "\"")
-
-let rec xmlescape ppcmd =
- let rec escape what withwhat (len, str) =
- try
- let pos = String.index str what in
- let (tlen, tail) =
- escape what withwhat ((len - pos - 1),
- (String.sub str (pos + 1) (len - pos - 1)))
- in
- (pos + tlen + String.length withwhat, String.sub str 0 pos ^ withwhat ^ tail)
- with Not_found -> (len, str)
- in
- match ppcmd with
- | Ppcmd_print (len, str) ->
- Ppcmd_print (escape '"' "&quot;"
- (escape '<' "&lt;" (escape '&' "&amp;" (len, str))))
- (* In XML we always print whole content so we can npeek the whole stream *)
- | Ppcmd_box (x, str) -> Ppcmd_box (x, Stream.of_list
- (List.map xmlescape (Stream.npeek max_int str)))
- | x -> x
-
-
-(* This flag tells if the last printed comment ends with a newline, to
- avoid empty lines *)
-let com_eol = ref false
-
-let com_brk ft = com_eol := false
-let com_if ft f =
- if !com_eol then (com_eol := false; Format.pp_force_newline ft ())
- else Lazy.force f
-
-let rec pr_com ft s =
- let (s1,os) =
- try
- let n = String.index s '\n' in
- String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1))
- with Not_found -> s,None in
- com_if ft (Lazy.lazy_from_val());
-(* let s1 =
- if String.length s1 <> 0 && s1.[0] = ' ' then
- (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1))
- else s1 in*)
- Format.pp_print_as ft (utf8_length s1) s1;
- match os with
- Some s2 ->
- if String.length s2 = 0 then (com_eol := true)
- else
- (Format.pp_force_newline ft (); pr_com ft s2)
- | None -> ()
-
-(* pretty printing functions *)
-let pp_dirs ft =
- let pp_open_box = function
- | Pp_hbox n -> Format.pp_open_hbox ft ()
- | Pp_vbox n -> Format.pp_open_vbox ft n
- | Pp_hvbox n -> Format.pp_open_hvbox ft n
- | Pp_hovbox n -> Format.pp_open_hovbox ft n
- | Pp_tbox -> Format.pp_open_tbox ft ()
- in
- let rec pp_cmd = function
- | Ppcmd_print(n,s) ->
- com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
- | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *)
- com_if ft (Lazy.lazy_from_val());
- pp_open_box bty ;
- if not (Format.over_max_boxes ()) then Stream.iter pp_cmd ss;
- Format.pp_close_box ft ()
- | Ppcmd_open_box bty -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty
- | Ppcmd_close_box -> Format.pp_close_box ft ()
- | Ppcmd_close_tbox -> Format.pp_close_tbox ft ()
- | Ppcmd_white_space n ->
- com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0))
- | Ppcmd_print_break(m,n) ->
- com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n))
- | Ppcmd_set_tab -> Format.pp_set_tab ft ()
- | Ppcmd_print_tbreak(m,n) ->
- com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n))
- | Ppcmd_force_newline ->
- com_brk ft; Format.pp_force_newline ft ()
- | Ppcmd_print_if_broken ->
- com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ()))
- | Ppcmd_comment i ->
- let coms = split_com [] [] i !comments in
-(* Format.pp_open_hvbox ft 0;*)
- List.iter (pr_com ft) coms(*;
- Format.pp_close_box ft ()*)
- in
- let pp_dir = function
- | Ppdir_ppcmds cmdstream -> Stream.iter pp_cmd cmdstream
- | Ppdir_print_newline ->
- com_brk ft; Format.pp_print_newline ft ()
- | Ppdir_print_flush -> Format.pp_print_flush ft ()
- in
- fun dirstream ->
- try
- Stream.iter pp_dir dirstream; com_brk ft
- with
- | reraise -> Format.pp_print_flush ft () ; raise reraise
-
-
-(* pretty print on stdout and stderr *)
-
-(* Special chars for emacs, to detect warnings inside goal output *)
-let emacs_quote_start = String.make 1 (Char.chr 254)
-let emacs_quote_end = String.make 1 (Char.chr 255)
-
-let emacs_quote strm =
- if !print_emacs then
- [< str emacs_quote_start; hov 0 strm; str emacs_quote_end >]
- else hov 0 strm
-
-let warnbody strm = emacs_quote (str "Warning: " ++ strm)
-
-(* pretty printing functions WITHOUT FLUSH *)
-let pp_with ft strm =
- pp_dirs ft [< 'Ppdir_ppcmds strm >]
-
-let ppnl_with ft strm =
- pp_dirs ft [< 'Ppdir_ppcmds [< strm ; 'Ppcmd_force_newline >] >]
-
-let default_warn_with ft strm = ppnl_with ft (warnbody strm)
-
-let pp_warn_with = ref default_warn_with
-
-let set_warning_function pp_warn = pp_warn_with := pp_warn
-
-let warn_with ft strm = !pp_warn_with ft strm
-
-let warning_with ft string = warn_with ft (str string)
-
-let pp_flush_with ft = Format.pp_print_flush ft
-
-(* pretty printing functions WITH FLUSH *)
-let msg_with ft strm =
- pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_flush >]
-
-let msgnl_with ft strm =
- pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_newline >]
-
-let msg_warning_with ft strm =
- msgnl_with ft (warnbody strm)
-
-(* pretty printing functions WITHOUT FLUSH *)
-let pp x = pp_with !std_ft x
-let ppnl x = ppnl_with !std_ft x
-let pperr x = pp_with !err_ft x
-let pperrnl x = ppnl_with !err_ft x
-let message s = ppnl (str s)
-let warning x = warning_with !err_ft x
-let warn x = warn_with !err_ft x
-let pp_flush x = Format.pp_print_flush !std_ft x
-let flush_all() = flush stderr; flush stdout; pp_flush()
-
-(* pretty printing functions WITH FLUSH *)
-let msg x = msg_with !std_ft x
-let msgnl x = msgnl_with !std_ft x
-let msgerr x = msg_with !err_ft x
-let msgerrnl x = msgnl_with !err_ft x
-let msg_warning x = msg_warning_with !err_ft x
-let msg_warn x = msg_warning (str x)
-
-(* Same specific display in emacs as warning, but without the "Warning:" *)
-let msg_debug x = msgnl (emacs_quote x)
-
-let string_of_ppcmds c =
- msg_with Format.str_formatter c;
- Format.flush_str_formatter ()
diff --git a/lib/pp.mli b/lib/pp.mli
index 695bcbc0..5dd2686d 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Pp_control
-
(** Modify pretty printing functions behavior for emacs ouput (special
chars inserted at some places). This function should called once in
module [Options], that's all. *)
@@ -16,11 +14,9 @@ val make_pp_nonemacs:unit -> unit
(** Pretty-printers. *)
-type ppcmd
-
-type std_ppcmds = ppcmd Stream.t
+type std_ppcmds
-(** {6 Formatting commands. } *)
+(** {6 Formatting commands} *)
val str : string -> std_ppcmds
val stras : int * string -> std_ppcmds
@@ -36,15 +32,24 @@ val ismt : std_ppcmds -> bool
val comment : int -> std_ppcmds
val comments : ((int * int) * string) list ref
-(** {6 Concatenation. } *)
+(** {6 Manipulation commands} *)
-val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
+val app : std_ppcmds -> std_ppcmds -> std_ppcmds
+(** Concatenation. *)
-(** {6 Evaluation. } *)
+val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
+(** Infix alias for [app]. *)
val eval_ppcmds : std_ppcmds -> std_ppcmds
+(** Force computation. *)
+
+val is_empty : std_ppcmds -> bool
+(** Test emptyness. *)
-(** {6 Derived commands. } *)
+val rewrite : (string -> string) -> std_ppcmds -> std_ppcmds
+(** [rewrite f pps] applies [f] to all strings that appear in [pps]. *)
+
+(** {6 Derived commands} *)
val spc : unit -> std_ppcmds
val cut : unit -> std_ppcmds
@@ -57,9 +62,7 @@ val qs : string -> std_ppcmds
val quote : std_ppcmds -> std_ppcmds
val strbrk : string -> std_ppcmds
-val xmlescape : ppcmd -> ppcmd
-
-(** {6 Boxing commands. } *)
+(** {6 Boxing commands} *)
val h : int -> std_ppcmds -> std_ppcmds
val v : int -> std_ppcmds -> std_ppcmds
@@ -67,7 +70,7 @@ val hv : int -> std_ppcmds -> std_ppcmds
val hov : int -> std_ppcmds -> std_ppcmds
val t : std_ppcmds -> std_ppcmds
-(** {6 Opening and closing of boxes. } *)
+(** {6 Opening and closing of boxes} *)
val hb : int -> std_ppcmds
val vb : int -> std_ppcmds
@@ -77,48 +80,200 @@ val tb : unit -> std_ppcmds
val close : unit -> std_ppcmds
val tclose : unit -> std_ppcmds
-(** {6 Pretty-printing functions {% \emph{%}without flush{% }%}. } *)
+(** {6 Opening and closing of tags} *)
-val pp_with : Format.formatter -> std_ppcmds -> unit
-val ppnl_with : Format.formatter -> std_ppcmds -> unit
-val warning_with : Format.formatter -> string -> unit
-val warn_with : Format.formatter -> std_ppcmds -> unit
-val pp_flush_with : Format.formatter -> unit -> unit
+module Tag :
+sig
+ type t
+ (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *)
-val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit
+ type 'a key
+ (** Keys used to inject tags *)
-(** {6 Pretty-printing functions {% \emph{%}with flush{% }%}. } *)
+ val create : string -> 'a key
+ (** Create a key with the given name. Two keys cannot share the same name, if
+ ever this is the case this function raises an assertion failure. *)
-val msg_with : Format.formatter -> std_ppcmds -> unit
-val msgnl_with : Format.formatter -> std_ppcmds -> unit
+ val inj : 'a -> 'a key -> t
+ (** Inject an object into a tag. *)
+
+ val prj : t -> 'a key -> 'a option
+ (** Project an object from a tag. *)
+end
+
+type tag_handler = Tag.t -> Format.tag
+
+val tag : Tag.t -> std_ppcmds -> std_ppcmds
+val open_tag : Tag.t -> std_ppcmds
+val close_tag : unit -> std_ppcmds
+
+(** {6 Sending messages to the user} *)
+type message_level = Feedback.message_level =
+ | Debug of string
+ | Info
+ | Notice
+ | Warning
+ | Error
+
+type message = Feedback.message = {
+ message_level : message_level;
+ message_content : string;
+}
+
+type logger = message_level -> std_ppcmds -> unit
+
+(** {6 output functions}
+
+[msg_notice] do not put any decoration on output by default. If
+possible don't mix it with goal output (prefer msg_info or
+msg_warning) so that interfaces can dispatch outputs easily. Once all
+interfaces use the xml-like protocol this constraint can be
+relaxed. *)
+(* Should we advertise these functions more? Should they be the ONLY
+ allowed way to output something? *)
+
+val msg_info : std_ppcmds -> unit
+(** Message that displays information, usually in verbose mode, such as [Foobar
+ is defined] *)
+
+val msg_notice : std_ppcmds -> unit
+(** Message that should be displayed, such as [Print Foo] or [Show Bar]. *)
+
+val msg_warning : std_ppcmds -> unit
+(** Message indicating that something went wrong, but without serious
+ consequences. *)
+
+val msg_error : std_ppcmds -> unit
+(** Message indicating that something went really wrong, though still
+ recoverable; otherwise an exception would have been raised. *)
+
+val msg_debug : std_ppcmds -> unit
+(** For debugging purposes *)
+
+val std_logger : logger
+(** Standard logging function *)
+
+val set_logger : logger -> unit
+
+val log_via_feedback : unit -> unit
+
+val of_message : message -> Xml_datatype.xml
+val to_message : Xml_datatype.xml -> message
+val is_message : Xml_datatype.xml -> bool
+
+
+(** {6 Feedback sent, even asynchronously, to the user interface} *)
+
+(* This stuff should be available to most of the system, line msg_* above.
+ * But I'm unsure this is the right place, especially for the global edit_id.
+ *
+ * Morally the parser gets a string and an edit_id, and gives back an AST.
+ * Feedbacks during the parsing phase are attached to this edit_id.
+ * The interpreter assignes an exec_id to the ast, and feedbacks happening
+ * during interpretation are attached to the exec_id.
+ * Only one among state_id and edit_id can be provided. *)
+
+val feedback :
+ ?state_id:Feedback.state_id -> ?edit_id:Feedback.edit_id ->
+ ?route:Feedback.route_id -> Feedback.feedback_content -> unit
+
+val set_id_for_feedback :
+ ?route:Feedback.route_id -> Feedback.edit_or_state_id -> unit
+val set_feeder : (Feedback.feedback -> unit) -> unit
+val get_id_for_feedback : unit -> Feedback.edit_or_state_id * Feedback.route_id
+
+(** {6 Utilities} *)
+val string_of_ppcmds : std_ppcmds -> string
+
+(** {6 Printing combinators} *)
+
+val pr_comma : unit -> std_ppcmds
+(** Well-spaced comma. *)
+
+val pr_semicolon : unit -> std_ppcmds
+(** Well-spaced semicolon. *)
+
+val pr_bar : unit -> std_ppcmds
+(** Well-spaced pipe bar. *)
+
+val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
+(** Adds a space in front of its argument. *)
+
+val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+(** Inner object preceded with a space if [Some], nothing otherwise. *)
+
+val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+(** Same as [pr_opt] but without the leading space. *)
+
+val pr_nth : int -> std_ppcmds
+(** Ordinal number with the correct suffix (i.e. "st", "nd", "th", etc.). *)
+
+val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Concatenation of the list contents, without any separator.
+
+ Unlike all other functions below, [prlist] works lazily. If a strict
+ behavior is needed, use [prlist_strict] instead. *)
+
+val prlist_strict : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Same as [prlist], but strict. *)
+
+val prlist_with_sep :
+ (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** [prlist_with_sep sep pr [a ; ... ; c]] outputs
+ [pr a ++ sep() ++ ... ++ sep() ++ pr c]. *)
+
+val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** As [prlist], but on arrays. *)
+
+val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** Indexed version of [prvect]. *)
+
+val prvect_with_sep :
+ (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** As [prlist_with_sep], but on arrays. *)
+
+val prvecti_with_sep :
+ (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** Indexed version of [prvect_with_sep]. *)
-(** {6 ... } *)
-(** The following functions are instances of the previous ones on
- [std_ft] and [err_ft]. *)
+val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** [pr_enum pr [a ; b ; ... ; c]] outputs
+ [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c]. *)
+
+val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Sequence of objects separated by space (unless an element is empty). *)
+
+val surround : std_ppcmds -> std_ppcmds
+(** Surround with parenthesis. *)
+
+val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds
+
+(** {6 Low-level pretty-printing functions {% \emph{%}without flush{% }%}. } *)
+
+val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit
(** {6 Pretty-printing functions {% \emph{%}without flush{% }%} on [stdout] and [stderr]. } *)
+(** These functions are low-level interface to printing and should not be used
+ in usual code. Consider using the [msg_*] function family instead. *)
+
val pp : std_ppcmds -> unit
val ppnl : std_ppcmds -> unit
val pperr : std_ppcmds -> unit
val pperrnl : std_ppcmds -> unit
-val message : string -> unit (** = pPNL *)
-val warning : string -> unit
-val warn : std_ppcmds -> unit
+val pperr_flush : unit -> unit
val pp_flush : unit -> unit
val flush_all: unit -> unit
-(** {6 Pretty-printing functions {% \emph{%}with flush{% }%} on [stdout] and [stderr]. } *)
+(** {6 Deprecated functions} *)
+
+(** DEPRECATED. Do not use in newly written code. *)
+
+val msg_with : Format.formatter -> std_ppcmds -> unit
val msg : std_ppcmds -> unit
val msgnl : std_ppcmds -> unit
val msgerr : std_ppcmds -> unit
val msgerrnl : std_ppcmds -> unit
-val msg_warning : std_ppcmds -> unit
-val msg_warn : string -> unit
-
-(** Same specific display in emacs as warning, but without the "Warning:" **)
-val msg_debug : std_ppcmds -> unit
-
-val string_of_ppcmds : std_ppcmds -> string
+val message : string -> unit (** = pPNL *)
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
index 94fdb881..0d224c03 100644
--- a/lib/pp_control.ml
+++ b/lib/pp_control.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -82,6 +82,7 @@ let set_depth_boxes v =
let get_margin () = Some (Format.pp_get_margin !std_ft ())
let set_margin v =
let v = match v with None -> default_margin | Some v -> v in
+ Format.pp_set_margin Format.str_formatter v;
Format.pp_set_margin !std_ft v;
Format.pp_set_margin !deep_ft v
diff --git a/lib/pp_control.mli b/lib/pp_control.mli
index 2c2d00f3..28d2e299 100644
--- a/lib/pp_control.mli
+++ b/lib/pp_control.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/lib/predicate.ml b/lib/predicate.ml
index e419aa6e..a60b3dad 100644
--- a/lib/predicate.ml
+++ b/lib/predicate.ml
@@ -54,8 +54,8 @@ module Make(Ord: OrderedType) =
let full = (true,EltSet.empty)
(* assumes the set is infinite *)
- let is_empty (b,s) = not b & EltSet.is_empty s
- let is_full (b,s) = b & EltSet.is_empty s
+ let is_empty (b,s) = not b && EltSet.is_empty s
+ let is_full (b,s) = b && EltSet.is_empty s
let mem x (b,s) =
if b then not (EltSet.mem x s) else EltSet.mem x s
@@ -92,6 +92,6 @@ module Make(Ord: OrderedType) =
| ((true,_),(false,_)) -> false
let equal (b1,s1) (b2,s2) =
- b1=b2 & EltSet.equal s1 s2
+ b1=b2 && EltSet.equal s1 s2
end
diff --git a/lib/profile.ml b/lib/profile.ml
index 0e4c2ebf..c55064ca 100644
--- a/lib/profile.ml
+++ b/lib/profile.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -221,7 +221,7 @@ let loops = 10000
let time_overhead_A_D () =
let e = create_record () in
let before = get_time () in
- for i=1 to loops do
+ for _i = 1 to loops do
(* This is a copy of profile1 for overhead estimation *)
let dw = dummy_spent_alloc () in
match !dummy_stack with [] -> assert false | p::_ ->
@@ -245,7 +245,7 @@ let time_overhead_A_D () =
done;
let after = get_time () in
let beforeloop = get_time () in
- for i=1 to loops do () done;
+ for _i = 1 to loops do () done;
let afterloop = get_time () in
float_of_int ((after - before) - (afterloop - beforeloop))
/. float_of_int loops
@@ -253,18 +253,18 @@ let time_overhead_A_D () =
let time_overhead_B_C () =
let dummy_x = 0 in
let before = get_time () in
- for i=1 to loops do
+ for _i = 1 to loops do
try
dummy_last_alloc := get_alloc ();
let _r = dummy_f dummy_x in
let _dw = dummy_spent_alloc () in
let _dt = get_time () in
()
- with e when e <> Sys.Break -> assert false
+ with e when Errors.noncritical e -> assert false
done;
let after = get_time () in
let beforeloop = get_time () in
- for i=1 to loops do () done;
+ for _i = 1 to loops do () done;
let afterloop = get_time () in
float_of_int ((after - before) - (afterloop - beforeloop))
/. float_of_int loops
@@ -279,7 +279,7 @@ let format_profile (table, outside, total) =
Printf.printf
"%-23s %9s %9s %10s %10s %10s\n"
"Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls ";
- let l = Sort.list (fun (_,{tottime=p}) (_,{tottime=p'}) -> p > p') table in
+ let l = List.sort (fun (_,{tottime=p}) (_,{tottime=p'}) -> p' - p) table in
List.iter (fun (name,e) ->
Printf.printf
"%-23s %9.2f %9.2f %10.0f %10.0f %6d %6d\n"
@@ -352,7 +352,7 @@ let close_profile print =
let print_profile () = close_profile true
let declare_profile name =
- if name = "___outside___" or name = "___total___" then
+ if name = "___outside___" || name = "___total___" then
failwith ("Error: "^name^" is a reserved keyword");
let e = create_record () in
prof_table := (name,e)::!prof_table;
@@ -657,80 +657,57 @@ let profile7 e f a b c d g h i =
last_alloc := get_alloc ();
raise reraise
-(* Some utilities to compute the logical and physical sizes and depth
- of ML objects *)
-
-let c = ref 0
-let s = ref 0
-let b = ref 0
-let m = ref 0
-
-let rec obj_stats d t =
- if Obj.is_int t then m := max d !m
- else if Obj.tag t >= Obj.no_scan_tag then
- if Obj.tag t = Obj.string_tag then
- (c := !c + Obj.size t; b := !b + 1; m := max d !m)
- else if Obj.tag t = Obj.double_tag then
- (s := !s + 2; b := !b + 1; m := max d !m)
- else if Obj.tag t = Obj.double_array_tag then
- (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m)
- else (b := !b + 1; m := max d !m)
- else
- let n = Obj.size t in
- s := !s + n; b := !b + 1;
- block_stats (d + 1) (n - 1) t
-
-and block_stats d i t =
- if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t)
-
-let obj_stats a =
- c := 0; s:= 0; b:= 0; m:= 0;
- obj_stats 0 (Obj.repr a);
- (!c, !s + !b, !m)
-
-module H = Hashtbl.Make(
- struct
- type t = Obj.t
- let equal = (==)
- let hash o = Hashtbl.hash (Obj.magic o : int)
- end)
-
-let tbl = H.create 13
-
-let rec obj_shared_size s t =
- if Obj.is_int t then s
- else if H.mem tbl t then s
- else begin
- H.add tbl t ();
- let n = Obj.size t in
- if Obj.tag t >= Obj.no_scan_tag then
- if Obj.tag t = Obj.string_tag then (c := !c + n; s + 1)
- else if Obj.tag t = Obj.double_tag then s + 3
- else if Obj.tag t = Obj.double_array_tag then s + 2 * n + 1
- else s + 1
- else
- block_shared_size (s + n + 1) (n - 1) t
- end
-
-and block_shared_size s i t =
- if i < 0 then s
- else block_shared_size (obj_shared_size s (Obj.field t i)) (i-1) t
-
-let obj_shared_size a =
- H.clear tbl;
- c := 0;
- let s = obj_shared_size 0 (Obj.repr a) in
- (!c, s)
+let profile8 e f a b c d g h i j =
+ let dw = spent_alloc () in
+ match !stack with [] -> assert false | p::_ ->
+ (* We add spent alloc since last measure to current caller own/total alloc *)
+ ajoute_ownalloc p dw;
+ ajoute_totalloc p dw;
+ e.owncount <- e.owncount + 1;
+ if not (p==e) then stack := e::!stack;
+ let totalloc0 = e.totalloc in
+ let intcount0 = e.intcount in
+ let t = get_time () in
+ try
+ last_alloc := get_alloc ();
+ let r = f a b c d g h i j in
+ let dw = spent_alloc () in
+ let dt = get_time () - t in
+ e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+ ajoute_ownalloc e dw;
+ ajoute_totalloc e dw;
+ p.owntime <- p.owntime - dt;
+ ajoute_totalloc p (e.totalloc -. totalloc0);
+ p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+ p.immcount <- p.immcount + 1;
+ if not (p==e) then
+ (match !stack with [] -> assert false | _::s -> stack := s);
+ last_alloc := get_alloc ();
+ r
+ with reraise ->
+ let dw = spent_alloc () in
+ let dt = get_time () - t in
+ e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+ ajoute_ownalloc e dw;
+ ajoute_totalloc e dw;
+ p.owntime <- p.owntime - dt;
+ ajoute_totalloc p (e.totalloc -. totalloc0);
+ p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+ p.immcount <- p.immcount + 1;
+ if not (p==e) then
+ (match !stack with [] -> assert false | _::s -> stack := s);
+ last_alloc := get_alloc ();
+ raise reraise
let print_logical_stats a =
- let (c, s, d) = obj_stats a in
+ let (c, s, d) = CObj.obj_stats a in
Printf.printf "Expanded size: %10d (str: %8d) Depth: %6d\n" (s+c) c d
let print_stats a =
- let (c1, s, d) = obj_stats a in
- let (c2, o) = obj_shared_size a in
- Printf.printf "Size: %8d (str: %8d) (exp: %10d) Depth: %6d\n"
- (o + c2) c2 (s + c1) d
+ let (c1, s, d) = CObj.obj_stats a in
+ let c2 = CObj.size a in
+ Printf.printf "Size: %8d (exp: %10d) Depth: %6d\n"
+ c2 (s + c1) d
(*
let _ = Gc.set { (Gc.get()) with Gc.verbose = 13 }
*)
diff --git a/lib/profile.mli b/lib/profile.mli
index 1e45ceed..e3221cd2 100644
--- a/lib/profile.mli
+++ b/lib/profile.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -100,6 +100,10 @@ val profile7 :
profile_key ->
('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h)
-> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h
+val profile8 :
+ profile_key ->
+ ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i)
+ -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i
(** Some utilities to compute the logical and physical sizes and depth
@@ -113,12 +117,3 @@ val print_logical_stats : 'a -> unit
This function allocates itself a lot (the same order of magnitude
as the physical size of its argument) *)
val print_stats : 'a -> unit
-
-(** Return logical size (first for strings, then for not strings),
- (in words) and depth of its argument
- This function allocates itself a lot *)
-val obj_stats : 'a -> int * int * int
-
-(** Return physical size of its argument (string part and rest)
- This function allocates itself a lot *)
-val obj_shared_size : 'a -> int * int
diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml
new file mode 100644
index 00000000..f4d7bb7b
--- /dev/null
+++ b/lib/remoteCounter.ml
@@ -0,0 +1,48 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type 'a getter = unit -> 'a
+type 'a installer = ('a getter) -> unit
+
+type remote_counters_status = (string * Obj.t) list
+
+let counters : remote_counters_status ref = ref []
+
+let (!!) x = !(!x)
+
+let new_counter ~name a ~incr ~build =
+ assert(not (List.mem_assoc name !counters));
+ let data = ref (ref a) in
+ counters := (name, Obj.repr data) :: !counters;
+ let m = Mutex.create () in
+ let mk_thsafe_getter f () =
+ (* - slaves must use a remote counter getter, not this one! *)
+ (* - in the main process there is a race condition between slave
+ managers (that are threads) and the main thread, hence the mutex *)
+ if Flags.async_proofs_is_worker () then
+ Errors.anomaly(Pp.str"Slave processes must install remote counters");
+ Mutex.lock m; let x = f () in Mutex.unlock m;
+ build x in
+ let getter = ref(mk_thsafe_getter (fun () -> !data := incr !!data; !!data)) in
+ let installer f =
+ if not (Flags.async_proofs_is_worker ()) then
+ Errors.anomaly(Pp.str"Only slave processes can install a remote counter");
+ getter := f in
+ (fun () -> !getter ()), installer
+
+let backup () = !counters
+
+let snapshot () =
+ List.map (fun (n,v) -> n, Obj.repr (ref (ref !!(Obj.obj v)))) !counters
+
+let restore l =
+ List.iter (fun (name, data) ->
+ assert(List.mem_assoc name !counters);
+ let dataref = Obj.obj (List.assoc name !counters) in
+ !dataref := !!(Obj.obj data))
+ l
diff --git a/lib/remoteCounter.mli b/lib/remoteCounter.mli
new file mode 100644
index 00000000..f3eca418
--- /dev/null
+++ b/lib/remoteCounter.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Remote counters are *global* counters for fresh ids. In the master/slave
+ * scenario, the slave installs a getter that asks the master for a fresh
+ * value. In the scenario of a slave that runs after the death of the master
+ * on some marshalled data, a backup of all counters status should be taken and
+ * restored to avoid reusing ids.
+ * Counters cannot be created by threads, they must be created once and forall
+ * as toplevel module declarations. *)
+
+
+type 'a getter = unit -> 'a
+type 'a installer = ('a getter) -> unit
+
+val new_counter : name:string ->
+ 'a -> incr:('a -> 'a) -> build:('a -> 'b) -> 'b getter * 'b installer
+
+type remote_counters_status
+val backup : unit -> remote_counters_status
+(* like backup but makes a copy so that further increment does not alter
+ * the snapshot *)
+val snapshot : unit -> remote_counters_status
+val restore : remote_counters_status -> unit
diff --git a/lib/richpp.ml b/lib/richpp.ml
new file mode 100644
index 00000000..745b7d2a
--- /dev/null
+++ b/lib/richpp.ml
@@ -0,0 +1,177 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+type 'annotation located = {
+ annotation : 'annotation option;
+ startpos : int;
+ endpos : int
+}
+
+let rich_pp annotate ppcmds =
+ (** First, we use Format to introduce tags inside
+ the pretty-printed document.
+
+ Each inserted tag is a fresh index that we keep in sync with the contents
+ of annotations.
+ *)
+ let annotations = ref [] in
+ let index = ref (-1) in
+ let pp_tag obj =
+ let () = incr index in
+ let () = annotations := obj :: !annotations in
+ string_of_int !index
+ in
+
+ let tagged_pp = Format.(
+
+ (** Warning: The following instructions are valid only if
+ [str_formatter] is not used for another purpose in
+ Pp.pp_with. *)
+
+ let ft = str_formatter in
+
+ (** We reuse {!Format} standard way of producing tags
+ inside pretty-printing. *)
+ pp_set_tags ft true;
+
+ (** The whole output must be a valid document. To that
+ end, we nest the document inside a tag named <pp>. *)
+ pp_open_tag ft "pp";
+
+ (** XML ignores spaces. The problem is that our pretty-printings
+ are based on spaces to indent. To solve that problem, we
+ systematically output non-breakable spaces, which are properly
+ honored by XML.
+
+ To do so, we reconfigure the [str_formatter] temporarily by
+ hijacking the function that output spaces. *)
+ let out, flush, newline, std_spaces =
+ pp_get_all_formatter_output_functions ft ()
+ in
+ let set = pp_set_all_formatter_output_functions ft ~out ~flush ~newline in
+ set ~spaces:(fun k ->
+ for i = 0 to k - 1 do
+ Buffer.add_string stdbuf "&nbsp;"
+ done
+ );
+
+ (** Some characters must be escaped in XML. This is done by the
+ following rewriting of the strings held by pretty-printing
+ commands. *)
+ Pp.(pp_with ~pp_tag ft (rewrite Xml_printer.pcdata_to_string ppcmds));
+
+ (** Insert </pp>. *)
+ pp_close_tag ft ();
+
+ (** Get the final string. *)
+ let output = flush_str_formatter () in
+
+ (** Finalize by restoring the state of the [str_formatter] and the
+ default behavior of Format. By the way, there may be a bug here:
+ there is no {!Format.pp_get_tags} and therefore if the tags flags
+ was already set to true before executing this piece of code, the
+ state of Format is not restored. *)
+ set ~spaces:std_spaces;
+ pp_set_tags ft false;
+ output
+ )
+ in
+ (** Second, we retrieve the final function that relates
+ each tag to an annotation. *)
+ let objs = CArray.rev_of_list !annotations in
+ let get index = annotate objs.(index) in
+
+ (** Third, we parse the resulting string. It is a valid XML
+ document (in the sense of Xml_parser). As blanks are
+ meaningful we deactivate canonicalization in the XML
+ parser. *)
+ let xml_pp =
+ try
+ Xml_parser.(parse ~do_not_canonicalize:true (make (SString tagged_pp)))
+ with Xml_parser.Error e ->
+ Printf.eprintf
+ "Broken invariant (RichPp): \n\
+ The output semi-structured pretty-printing is ill-formed.\n\
+ Please report.\n\
+ %s"
+ (Xml_parser.error e);
+ exit 1
+ in
+
+ (** Fourth, the low-level XML is turned into a high-level
+ semi-structured document that contains a located annotation in
+ every node. During the traversal of the low-level XML document,
+ we build a raw string representation of the pretty-print. *)
+ let rec node buffer = function
+ | Element (index, [], cs) ->
+ let startpos, endpos, cs = children buffer cs in
+ let annotation = try get (int_of_string index) with _ -> None in
+ (Element (index, { annotation; startpos; endpos }, cs), endpos)
+
+ | PCData s ->
+ Buffer.add_string buffer s;
+ (PCData s, Buffer.length buffer)
+
+ | _ ->
+ assert false (* Because of the form of XML produced by Format. *)
+
+ and children buffer cs =
+ let startpos = Buffer.length buffer in
+ let cs, endpos =
+ List.fold_left (fun (cs, endpos) c ->
+ let c, endpos = node buffer c in
+ (c :: cs, endpos)
+ ) ([], startpos) cs
+ in
+ (startpos, endpos, List.rev cs)
+ in
+ let pp_buffer = Buffer.create 13 in
+ let xml, _ = node pp_buffer xml_pp in
+
+ (** We return the raw pretty-printing and its annotations tree. *)
+ (Buffer.contents pp_buffer, xml)
+
+let annotations_positions xml =
+ let rec node accu = function
+ | Element (_, { annotation = Some annotation; startpos; endpos }, cs) ->
+ children ((annotation, (startpos, endpos)) :: accu) cs
+ | Element (_, _, cs) ->
+ children accu cs
+ | _ ->
+ accu
+ and children accu cs =
+ List.fold_left node accu cs
+ in
+ node [] xml
+
+let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml =
+ let rec node = function
+ | Element (index, { annotation; startpos; endpos }, cs) ->
+ let attributes =
+ [ "startpos", string_of_int startpos;
+ "endpos", string_of_int endpos
+ ]
+ @ (match annotation with
+ | None -> []
+ | Some annotation -> attributes_of_annotation annotation
+ )
+ in
+ let tag =
+ match annotation with
+ | None -> index
+ | Some annotation -> tag_of_annotation annotation
+ in
+ Element (tag, attributes, List.map node cs)
+ | PCData s ->
+ PCData s
+ in
+ node xml
+
+
diff --git a/lib/richpp.mli b/lib/richpp.mli
new file mode 100644
index 00000000..446ee1a0
--- /dev/null
+++ b/lib/richpp.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** This module offers semi-structured pretty-printing. *)
+
+(** Each annotation of the semi-structured document refers to the
+ substring it annotates. *)
+type 'annotation located = {
+ annotation : 'annotation option;
+ startpos : int;
+ endpos : int
+}
+
+(** [rich_pp get_annotations ppcmds] returns the interpretation
+ of [ppcmds] as a string as well as a semi-structured document
+ that represents (located) annotations of this string.
+ The [get_annotations] function is used to convert tags into the desired
+ annotation. If this function returns [None], then no annotation is put. *)
+val rich_pp :
+ (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds ->
+ string * 'annotation located Xml_datatype.gxml
+
+(** [annotations_positions ssdoc] returns a list associating each
+ annotations with its position in the string from which [ssdoc] is
+ built. *)
+val annotations_positions :
+ 'annotation located Xml_datatype.gxml ->
+ ('annotation * (int * int)) list
+
+(** [xml_of_rich_pp ssdoc] returns an XML representation of the
+ semi-structured document [ssdoc]. *)
+val xml_of_rich_pp :
+ ('annotation -> string) ->
+ ('annotation -> (string * string) list) ->
+ 'annotation located Xml_datatype.gxml ->
+ Xml_datatype.xml
diff --git a/lib/rtree.ml b/lib/rtree.ml
index cfac6aa4..f395c086 100644
--- a/lib/rtree.ml
+++ b/lib/rtree.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,17 +8,15 @@
open Util
-
(* Type of regular trees:
- Param denotes tree variables (like de Bruijn indices)
the first int is the depth of the occurrence, and the second int
- is the index in the array of trees introduced at that depth
+ is the index in the array of trees introduced at that depth.
+ Warning: Param's indices both start at 0!
- Node denotes the usual tree node, labelled with 'a
- Rec(j,v1..vn) introduces infinite tree. It denotes
v(j+1) with parameters 0..n-1 replaced by
Rec(0,v1..vn)..Rec(n-1,v1..vn) respectively.
- Parameters n and higher denote parameters global to the
- current Rec node (as usual in de Bruijn binding system)
*)
type 'a t =
Param of int * int
@@ -36,27 +34,26 @@ let rec lift_rtree_rec depth n = function
| Rec(j,defs) ->
Rec(j, Array.map (lift_rtree_rec (depth+1) n) defs)
-let lift n t = if n=0 then t else lift_rtree_rec 0 n t
+let lift n t = if Int.equal n 0 then t else lift_rtree_rec 0 n t
(* The usual subst operation *)
let rec subst_rtree_rec depth sub = function
Param (i,j) as t ->
if i < depth then t
- else if i-depth < Array.length sub then
- lift depth sub.(i-depth).(j)
- else Param (i-Array.length sub,j)
+ else if i = depth then
+ lift depth (Rec (j, sub))
+ else Param (i - 1, j)
| Node (l,sons) -> Node (l,Array.map (subst_rtree_rec depth sub) sons)
| Rec(j,defs) ->
Rec(j, Array.map (subst_rtree_rec (depth+1) sub) defs)
-let subst_rtree sub t = subst_rtree_rec 0 [|sub|] t
+let subst_rtree sub t = subst_rtree_rec 0 sub t
(* To avoid looping, we must check that every body introduces a node
or a parameter *)
let rec expand = function
| Rec(j,defs) ->
- let sub = Array.init (Array.length defs) (fun i -> Rec(i,defs)) in
- expand (subst_rtree sub defs.(j))
+ expand (subst_rtree defs defs.(j))
| t -> t
(* Given a vector of n bodies, builds the n mutual recursive trees.
@@ -65,12 +62,13 @@ let rec expand = function
directly one of the parameters of depth 0. Some care is taken to
accept definitions like rec X=Y and Y=f(X,Y) *)
let mk_rec defs =
- let rec check histo d =
- match expand d with
- Param(0,j) when List.mem j histo -> failwith "invalid rec call"
- | Param(0,j) -> check (j::histo) defs.(j)
- | _ -> () in
- Array.mapi (fun i d -> check [i] d; Rec(i,defs)) defs
+ let rec check histo d = match expand d with
+ | Param (0, j) ->
+ if Int.Set.mem j histo then failwith "invalid rec call"
+ else check (Int.Set.add j histo) defs.(j)
+ | _ -> ()
+ in
+ Array.mapi (fun i d -> check (Int.Set.singleton i) d; Rec(i,defs)) defs
(*
let v(i,j) = lift i (mk_rec_calls(j+1)).(j);;
let r = (mk_rec[|(mk_rec[|v(1,0)|]).(0)|]).(0);;
@@ -100,69 +98,96 @@ let rec map f t = match t with
| Node (a,sons) -> Node (f a, Array.map (map f) sons)
| Rec(j,defs) -> Rec (j, Array.map (map f) defs)
-let rec smartmap f t = match t with
+let smartmap f t = match t with
Param _ -> t
| Node (a,sons) ->
- let a'=f a and sons' = Util.array_smartmap (map f) sons in
- if a'==a && sons'==sons then
- t
- else
- Node (a',sons')
+ let a'=f a and sons' = Array.smartmap (map f) sons in
+ if a'==a && sons'==sons then t
+ else Node (a',sons')
| Rec(j,defs) ->
- let defs' = Util.array_smartmap (map f) defs in
- if defs'==defs then
- t
- else
- Rec(j,defs')
-
-(* Fixpoint operator on trees:
- f is the body of the fixpoint. Arguments passed to f are:
- - a boolean telling if the subtree has already been seen
- - the current subtree
- - a function to make recursive calls on subtrees
- *)
-let fold f t =
- let rec fold histo t =
- let seen = List.mem t histo in
- let nhisto = if not seen then t::histo else histo in
- f seen (expand t) (fold nhisto) in
- fold [] t
-
-
-(* Tests if a given tree is infinite, i.e. has an branch of infinte length. *)
-let is_infinite t = fold
- (fun seen t is_inf ->
- seen ||
- (match t with
- Node(_,v) -> array_exists is_inf v
- | Param _ -> false
- | _ -> assert false))
- t
-
-let fold2 f t x =
- let rec fold histo t x =
- let seen = List.mem (t,x) histo in
- let nhisto = if not seen then (t,x)::histo else histo in
- f seen (expand t) x (fold nhisto) in
- fold [] t x
-
-let compare_rtree f = fold2
- (fun seen t1 t2 cmp ->
- seen ||
- let b = f t1 t2 in
- if b < 0 then false
- else if b > 0 then true
- else match expand t1, expand t2 with
- Node(_,v1), Node(_,v2) when Array.length v1 = Array.length v2 ->
- array_for_all2 cmp v1 v2
- | _ -> false)
-
-let eq_rtree cmp t1 t2 =
- t1 == t2 || t1=t2 ||
- compare_rtree
- (fun t1 t2 ->
- if cmp (fst(dest_node t1)) (fst(dest_node t2)) then 0
- else (-1)) t1 t2
+ let defs' = Array.smartmap (map f) defs in
+ if defs'==defs then t
+ else Rec(j,defs')
+
+(** Structural equality test, parametrized by an equality on elements *)
+
+let rec raw_eq cmp t t' = match t, t' with
+ | Param (i,j), Param (i',j') -> Int.equal i i' && Int.equal j j'
+ | Node (x, a), Node (x', a') -> cmp x x' && Array.equal (raw_eq cmp) a a'
+ | Rec (i, a), Rec (i', a') -> Int.equal i i' && Array.equal (raw_eq cmp) a a'
+ | _ -> false
+
+let raw_eq2 cmp (t,u) (t',u') = raw_eq cmp t t' && raw_eq cmp u u'
+
+(** Equivalence test on expanded trees. It is parametrized by two
+ equalities on elements:
+ - [cmp] is used when checking for already seen trees
+ - [cmp'] is used when comparing node labels. *)
+
+let equiv cmp cmp' =
+ let rec compare histo t t' =
+ List.mem_f (raw_eq2 cmp) (t,t') histo ||
+ match expand t, expand t' with
+ | Node(x,v), Node(x',v') ->
+ cmp' x x' &&
+ Int.equal (Array.length v) (Array.length v') &&
+ Array.for_all2 (compare ((t,t')::histo)) v v'
+ | _ -> false
+ in compare []
+
+(** The main comparison on rtree tries first physical equality, then
+ the structural one, then the logical equivalence *)
+
+let equal cmp t t' =
+ t == t' || raw_eq cmp t t' || equiv cmp cmp t t'
+
+(** Deprecated alias *)
+let eq_rtree = equal
+
+(** Intersection of rtrees of same arity *)
+let rec inter cmp interlbl def n histo t t' =
+ try
+ let (i,j) = List.assoc_f (raw_eq2 cmp) (t,t') histo in
+ Param (n-i-1,j)
+ with Not_found ->
+ match t, t' with
+ | Param (i,j), Param (i',j') ->
+ assert (Int.equal i i' && Int.equal j j'); t
+ | Node (x, a), Node (x', a') ->
+ (match interlbl x x' with
+ | None -> mk_node def [||]
+ | Some x'' -> Node (x'', Array.map2 (inter cmp interlbl def n histo) a a'))
+ | Rec (i,v), Rec (i',v') ->
+ (* If possible, we preserve the shape of input trees *)
+ if Int.equal i i' && Int.equal (Array.length v) (Array.length v') then
+ let histo = ((t,t'),(n,i))::histo in
+ Rec(i, Array.map2 (inter cmp interlbl def (n+1) histo) v v')
+ else
+ (* Otherwise, mutually recursive trees are transformed into nested trees *)
+ let histo = ((t,t'),(n,0))::histo in
+ Rec(0, [|inter cmp interlbl def (n+1) histo (expand t) (expand t')|])
+ | Rec _, _ -> inter cmp interlbl def n histo (expand t) t'
+ | _ , Rec _ -> inter cmp interlbl def n histo t (expand t')
+ | _ -> assert false
+
+let inter cmp interlbl def t t' = inter cmp interlbl def 0 [] t t'
+
+(** Inclusion of rtrees. We may want a more efficient implementation. *)
+let incl cmp interlbl def t t' =
+ equal cmp t (inter cmp interlbl def t t')
+
+(** Tests if a given tree is infinite, i.e. has a branch of infinite length.
+ This corresponds to a cycle when visiting the expanded tree.
+ We use a specific comparison to detect already seen trees. *)
+
+let is_infinite cmp t =
+ let rec is_inf histo t =
+ List.mem_f (raw_eq cmp) t histo ||
+ match expand t with
+ | Node (_,v) -> Array.exists (is_inf (t::histo)) v
+ | _ -> false
+ in
+ is_inf [] t
(* Pretty-print a tree (not so pretty) *)
open Pp
@@ -173,11 +198,11 @@ let rec pp_tree prl t =
| Node(lab,[||]) -> hov 2 (str"("++prl lab++str")")
| Node(lab,v) ->
hov 2 (str"("++prl lab++str","++brk(1,0)++
- Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str")")
+ prvect_with_sep pr_comma (pp_tree prl) v++str")")
| Rec(i,v) ->
- if Array.length v = 0 then str"Rec{}"
- else if Array.length v = 1 then
+ if Int.equal (Array.length v) 0 then str"Rec{}"
+ else if Int.equal (Array.length v) 1 then
hov 2 (str"Rec{"++pp_tree prl v.(0)++str"}")
else
hov 2 (str"Rec{"++int i++str","++brk(1,0)++
- Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str"}")
+ prvect_with_sep pr_comma (pp_tree prl) v++str"}")
diff --git a/lib/rtree.mli b/lib/rtree.mli
index 8b12fee1..0b9424b8 100644
--- a/lib/rtree.mli
+++ b/lib/rtree.mli
@@ -1,12 +1,12 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(** Type of regular tree with nodes labelled by values of type 'a
+(** Type of regular tree with nodes labelled by values of type 'a
The implementation uses de Bruijn indices, so binding capture
is avoided by the lift operator (see example below) *)
type 'a t
@@ -49,22 +49,26 @@ val dest_node : 'a t -> 'a * 'a t array
(** dest_param is not needed for closed trees (i.e. with no free variable) *)
val dest_param : 'a t -> int * int
-(** Tells if a tree has an infinite branch *)
-val is_infinite : 'a t -> bool
-
-(** [compare_rtree f t1 t2] compares t1 t2 (top-down).
- f is called on each node: if the result is negative then the
- traversal ends on false, it is is positive then deeper nodes are
- not examined, and the traversal continues on respective siblings,
- and if it is 0, then the traversal continues on sons, pairwise.
- In this latter case, if the nodes do not have the same number of
- sons, then the traversal ends on false.
- In case of loop, the traversal is successful and it resumes on
- siblings.
- *)
-val compare_rtree : ('a t -> 'b t -> int) -> 'a t -> 'b t -> bool
+(** Tells if a tree has an infinite branch. The first arg is a comparison
+ used to detect already seen elements, hence loops *)
+val is_infinite : ('a -> 'a -> bool) -> 'a t -> bool
-val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+(** [Rtree.equiv eq eqlab t1 t2] compares t1 t2 (top-down).
+ If t1 and t2 are both nodes, [eqlab] is called on their labels,
+ in case of success deeper nodes are examined.
+ In case of loop (detected via structural equality parametrized
+ by [eq]), then the comparison is successful. *)
+val equiv :
+ ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+(** [Rtree.equal eq t1 t2] compares t1 and t2, first via physical
+ equality, then by structural equality (using [eq] on elements),
+ then by logical equivalence [Rtree.equiv eq eq] *)
+val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+val inter : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t -> 'a t
+
+val incl : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t -> bool
(** Iterators *)
@@ -72,9 +76,9 @@ val map : ('a -> 'b) -> 'a t -> 'b t
(** [(smartmap f t) == t] if [(f a) ==a ] for all nodes *)
val smartmap : ('a -> 'a) -> 'a t -> 'a t
-val fold : (bool -> 'a t -> ('a t -> 'b) -> 'b) -> 'a t -> 'b
-val fold2 :
- (bool -> 'a t -> 'b -> ('a t -> 'b -> 'c) -> 'c) -> 'a t -> 'b -> 'c
(** A rather simple minded pretty-printer *)
val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
+
+val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+(** @deprecated Same as [Rtree.equal] *)
diff --git a/lib/serialize.ml b/lib/serialize.ml
new file mode 100644
index 00000000..aa2e3f02
--- /dev/null
+++ b/lib/serialize.ml
@@ -0,0 +1,116 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+exception Marshal_error
+
+(** Utility functions *)
+
+let rec get_attr attr = function
+ | [] -> raise Not_found
+ | (k, v) :: l when CString.equal k attr -> v
+ | _ :: l -> get_attr attr l
+
+let massoc x l =
+ try get_attr x l
+ with Not_found -> raise Marshal_error
+
+let constructor t c args = Element (t, ["val", c], args)
+let do_match t mf = function
+ | Element (s, attrs, args) when CString.equal s t ->
+ let c = massoc "val" attrs in
+ mf c args
+ | _ -> raise Marshal_error
+
+let singleton = function
+ | [x] -> x
+ | _ -> raise Marshal_error
+
+let raw_string = function
+ | [] -> ""
+ | [PCData s] -> s
+ | _ -> raise Marshal_error
+
+(** Base types *)
+
+let of_unit () = Element ("unit", [], [])
+let to_unit : xml -> unit = function
+ | Element ("unit", [], []) -> ()
+ | _ -> raise Marshal_error
+
+let of_bool (b : bool) : xml =
+ if b then constructor "bool" "true" []
+ else constructor "bool" "false" []
+let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with
+ | "true" -> true
+ | "false" -> false
+ | _ -> raise Marshal_error)
+
+let of_list (f : 'a -> xml) (l : 'a list) =
+ Element ("list", [], List.map f l)
+let to_list (f : xml -> 'a) : xml -> 'a list = function
+ | Element ("list", [], l) -> List.map f l
+ | _ -> raise Marshal_error
+
+let of_option (f : 'a -> xml) : 'a option -> xml = function
+ | None -> Element ("option", ["val", "none"], [])
+ | Some x -> Element ("option", ["val", "some"], [f x])
+let to_option (f : xml -> 'a) : xml -> 'a option = function
+ | Element ("option", ["val", "none"], []) -> None
+ | Element ("option", ["val", "some"], [x]) -> Some (f x)
+ | _ -> raise Marshal_error
+
+let of_string (s : string) : xml = Element ("string", [], [PCData s])
+let to_string : xml -> string = function
+ | Element ("string", [], l) -> raw_string l
+ | _ -> raise Marshal_error
+
+let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)])
+let to_int : xml -> int = function
+ | Element ("int", [], [PCData s]) ->
+ (try int_of_string s with Failure _ -> raise Marshal_error)
+ | _ -> raise Marshal_error
+
+let of_pair (f : 'a -> xml) (g : 'b -> xml) (x : 'a * 'b) : xml =
+ Element ("pair", [], [f (fst x); g (snd x)])
+let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function
+ | Element ("pair", [], [x; y]) -> (f x, g y)
+ | _ -> raise Marshal_error
+
+let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = function
+ | CSig.Inl x -> Element ("union", ["val","in_l"], [f x])
+ | CSig.Inr x -> Element ("union", ["val","in_r"], [g x])
+let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) CSig.union = function
+ | Element ("union", ["val","in_l"], [x]) -> CSig.Inl (f x)
+ | Element ("union", ["val","in_r"], [x]) -> CSig.Inr (g x)
+ | _ -> raise Marshal_error
+
+(** More elaborate types *)
+
+let of_edit_id i = Element ("edit_id",["val",string_of_int i],[])
+let to_edit_id = function
+ | Element ("edit_id",["val",i],[]) ->
+ let id = int_of_string i in
+ assert (id <= 0 );
+ id
+ | _ -> raise Marshal_error
+
+let of_loc loc =
+ let start, stop = Loc.unloc loc in
+ Element ("loc",[("start",string_of_int start);("stop",string_of_int stop)],[])
+let to_loc xml =
+ match xml with
+ | Element ("loc", l,[]) ->
+ (try
+ let start = massoc "start" l in
+ let stop = massoc "stop" l in
+ Loc.make_loc (int_of_string start, int_of_string stop)
+ with Not_found | Invalid_argument _ -> raise Marshal_error)
+ | _ -> raise Marshal_error
+
diff --git a/lib/serialize.mli b/lib/serialize.mli
new file mode 100644
index 00000000..34d3e054
--- /dev/null
+++ b/lib/serialize.mli
@@ -0,0 +1,37 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+exception Marshal_error
+
+val massoc: string -> (string * string) list -> string
+val constructor: string -> string -> xml list -> xml
+val do_match: string -> (string -> xml list -> 'b) -> xml -> 'b
+val singleton: 'a list -> 'a
+val raw_string: xml list -> string
+val of_unit: unit -> xml
+val to_unit: xml -> unit
+val of_bool: bool -> xml
+val to_bool: xml -> bool
+val of_list: ('a -> xml) -> 'a list -> xml
+val to_list: (xml -> 'a) -> xml -> 'a list
+val of_option: ('a -> xml) -> 'a option -> xml
+val to_option: (xml -> 'a) -> xml -> 'a option
+val of_string: string -> xml
+val to_string: xml -> string
+val of_int: int -> xml
+val to_int: xml -> int
+val of_pair: ('a -> xml) -> ('b -> xml) -> 'a * 'b -> xml
+val to_pair: (xml -> 'a) -> (xml -> 'b) -> xml -> 'a * 'b
+val of_union: ('a -> xml) -> ('b -> xml) -> ('a, 'b) CSig.union -> xml
+val to_union: (xml -> 'a) -> (xml -> 'b) -> xml -> ('a, 'b) CSig.union
+val of_edit_id: int -> xml
+val to_edit_id: xml -> int
+val of_loc : Loc.t -> xml
+val to_loc : xml -> Loc.t
diff --git a/lib/spawn.ml b/lib/spawn.ml
new file mode 100644
index 00000000..9b63be70
--- /dev/null
+++ b/lib/spawn.ml
@@ -0,0 +1,258 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+let proto_version = 0
+let prefer_sock = Sys.os_type = "Win32"
+let accept_timeout = 2.0
+
+let pr_err s = Printf.eprintf "(Spawn ,%d) %s\n%!" (Unix.getpid ()) s
+let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
+
+type req = ReqDie | ReqStats | Hello of int * int
+type resp = RespStats of Gc.stat
+
+module type Control = sig
+ type handle
+
+ val kill : handle -> unit
+ val stats : handle -> Gc.stat
+ val wait : handle -> Unix.process_status
+ val unixpid : handle -> int
+ val uid : handle -> string
+ val is_alive : handle -> bool
+
+end
+
+module type Empty = sig end
+
+module type MainLoopModel = sig
+ type async_chan
+ type condition
+ type watch_id
+
+ val add_watch : callback:(condition list -> bool) -> async_chan -> watch_id
+ val remove_watch : watch_id -> unit
+ val read_all : async_chan -> string
+ val async_chan_of_file : Unix.file_descr -> async_chan
+ val async_chan_of_socket : Unix.file_descr -> async_chan
+end
+
+(* Common code *)
+let assert_ b s = if not b then Errors.anomaly (Pp.str s)
+
+let mk_socket_channel () =
+ let open Unix in
+ let s = socket PF_INET SOCK_STREAM 0 in
+ bind s (ADDR_INET (inet_addr_loopback,0));
+ listen s 1;
+ match getsockname s with
+ | ADDR_INET(host, port) ->
+ s, string_of_inet_addr host ^":"^ string_of_int port
+ | _ -> assert false
+
+let accept s =
+ let r, _, _ = Unix.select [s] [] [] accept_timeout in
+ if r = [] then raise (Failure (Printf.sprintf
+ "The spawned process did not connect back in %2.1fs" accept_timeout));
+ let cs, _ = Unix.accept s in
+ Unix.close s;
+ let cin, cout = Unix.in_channel_of_descr cs, Unix.out_channel_of_descr cs in
+ set_binary_mode_in cin true;
+ set_binary_mode_out cout true;
+ cs, cin, cout
+
+let handshake cin cout =
+ try
+ output_value cout (Hello (proto_version,Unix.getpid ())); flush cout;
+ match input_value cin with
+ | Hello(v, pid) when v = proto_version ->
+ prerr_endline (Printf.sprintf "Handshake with %d OK" pid);
+ pid
+ | _ -> raise (Failure "handshake protocol")
+ with
+ | Failure s | Invalid_argument s | Sys_error s ->
+ pr_err ("Handshake failed: " ^ s); raise (Failure "handshake")
+ | End_of_file ->
+ pr_err "Handshake failed: End_of_file"; raise (Failure "handshake")
+
+let spawn_sock env prog args =
+ let main_sock, main_sock_name = mk_socket_channel () in
+ let extra = [| prog; "-main-channel"; main_sock_name |] in
+ let args = Array.append extra args in
+ prerr_endline ("EXEC: " ^ String.concat " " (Array.to_list args));
+ let pid =
+ Unix.create_process_env prog args env Unix.stdin Unix.stdout Unix.stderr in
+ if pid = 0 then begin
+ Unix.sleep 1; (* to avoid respawning like crazy *)
+ raise (Failure "create_process failed")
+ end;
+ let cs, cin, cout = accept main_sock in
+ pid, cin, cout, cs
+
+let spawn_pipe env prog args =
+ let master2worker_r,master2worker_w = Unix.pipe () in
+ let worker2master_r,worker2master_w = Unix.pipe () in
+ let extra = [| prog; "-main-channel"; "stdfds" |] in
+ let args = Array.append extra args in
+ Unix.set_close_on_exec master2worker_w;
+ Unix.set_close_on_exec worker2master_r;
+ prerr_endline ("EXEC: " ^ String.concat " " (Array.to_list args));
+ let pid =
+ Unix.create_process_env
+ prog args env master2worker_r worker2master_w Unix.stderr in
+ if pid = 0 then begin
+ Unix.sleep 1; (* to avoid respawning like crazy *)
+ raise (Failure "create_process failed")
+ end;
+ prerr_endline ("PID " ^ string_of_int pid);
+ Unix.close master2worker_r;
+ Unix.close worker2master_w;
+ let cin = Unix.in_channel_of_descr worker2master_r in
+ let cout = Unix.out_channel_of_descr master2worker_w in
+ set_binary_mode_in cin true;
+ set_binary_mode_out cout true;
+ pid, cin, cout, worker2master_r
+
+let filter_args args =
+ let rec aux = function
+ | "-control-channel" :: _ :: rest -> aux rest
+ | "-main-channel" :: _ :: rest -> aux rest
+ | x :: rest -> x :: aux rest
+ | [] -> [] in
+ Array.of_list (aux (Array.to_list args))
+
+let spawn_with_control prefer_sock env prog args =
+ let control_sock, control_sock_name = mk_socket_channel () in
+ let extra = [| "-control-channel"; control_sock_name |] in
+ let args = Array.append extra (filter_args args) in
+ let (pid, cin, cout, s), is_sock =
+ if Sys.os_type <> "Unix" || prefer_sock
+ then spawn_sock env prog args, true
+ else spawn_pipe env prog args, false in
+ let _, oob_resp, oob_req = accept control_sock in
+ pid, oob_resp, oob_req, cin, cout, s, is_sock
+
+let output_death_sentence pid oob_req =
+ prerr_endline ("death sentence for " ^ pid);
+ try output_value oob_req ReqDie; flush oob_req
+ with e -> prerr_endline ("death sentence: " ^ Printexc.to_string e)
+
+(* spawn a process and read its output asynchronously *)
+module Async(ML : MainLoopModel) = struct
+
+type process = {
+ cin : in_channel;
+ cout : out_channel;
+ oob_resp : in_channel;
+ oob_req : out_channel;
+ gchan : ML.async_chan;
+ pid : int;
+ mutable watch : ML.watch_id option;
+ mutable alive : bool;
+}
+
+type callback = ML.condition list -> read_all:(unit -> string) -> bool
+type handle = process
+
+let is_alive p = p.alive
+let uid { pid; } = string_of_int pid
+let unixpid { pid; } = pid
+
+let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) =
+ p.alive <- false;
+ if not alive then prerr_endline "This process is already dead"
+ else begin try
+ Option.iter ML.remove_watch watch;
+ output_death_sentence (uid p) oob_req;
+ close_in_noerr cin;
+ close_out_noerr cout;
+ if Sys.os_type = "Unix" then Unix.kill unixpid 9;
+ p.watch <- None
+ with e -> prerr_endline ("kill: "^Printexc.to_string e) end
+
+let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ())
+ prog args callback
+=
+ let pid, oob_resp, oob_req, cin, cout, main, is_sock =
+ spawn_with_control prefer_sock env prog args in
+ Unix.set_nonblock main;
+ let gchan =
+ if is_sock then ML.async_chan_of_socket main
+ else ML.async_chan_of_file main in
+ let alive, watch = true, None in
+ let p = { cin; cout; gchan; pid; oob_resp; oob_req; alive; watch } in
+ p.watch <- Some (
+ ML.add_watch ~callback:(fun cl ->
+ try
+ let live = callback cl ~read_all:(fun () -> ML.read_all gchan) in
+ if not live then kill p;
+ live
+ with e when Errors.noncritical e ->
+ pr_err ("Async reader raised: " ^ (Printexc.to_string e));
+ kill p;
+ false) gchan
+ );
+ p, cout
+
+let stats { oob_req; oob_resp; alive } =
+ assert_ alive "This process is dead";
+ output_value oob_req ReqStats;
+ flush oob_req;
+ input_value oob_resp
+
+let rec wait p =
+ try snd (Unix.waitpid [] p.pid)
+ with
+ | Unix.Unix_error (Unix.EINTR, _, _) -> wait p
+ | Unix.Unix_error _ -> Unix.WEXITED 0o400
+
+end
+
+module Sync(T : Empty) = struct
+
+type process = {
+ cin : in_channel;
+ cout : out_channel;
+ oob_resp : in_channel;
+ oob_req : out_channel;
+ pid : int;
+ mutable alive : bool;
+}
+
+type handle = process
+
+let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) prog args =
+ let pid, oob_resp, oob_req, cin, cout, _, _ =
+ spawn_with_control prefer_sock env prog args in
+ { cin; cout; pid; oob_resp; oob_req; alive = true }, cin, cout
+
+let is_alive p = p.alive
+let uid { pid; } = string_of_int pid
+let unixpid { pid = pid; } = pid
+
+let kill ({ pid = unixpid; oob_req; cin; cout; alive } as p) =
+ p.alive <- false;
+ if not alive then prerr_endline "This process is already dead"
+ else begin try
+ output_death_sentence (uid p) oob_req;
+ close_in_noerr cin;
+ close_out_noerr cout;
+ if Sys.os_type = "Unix" then Unix.kill unixpid 9;
+ with e -> prerr_endline ("kill: "^Printexc.to_string e) end
+
+let stats { oob_req; oob_resp; alive } =
+ assert_ alive "This process is dead";
+ output_value oob_req ReqStats;
+ flush oob_req;
+ let RespStats g = input_value oob_resp in g
+
+let wait { pid = unixpid } =
+ try snd (Unix.waitpid [] unixpid)
+ with Unix.Unix_error _ -> Unix.WEXITED 0o400
+
+end
diff --git a/lib/spawn.mli b/lib/spawn.mli
new file mode 100644
index 00000000..8022573b
--- /dev/null
+++ b/lib/spawn.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* This module implements spawning/killing managed processes with a
+ * synchronous or asynchronous comunication channel that works with
+ * threads or with a glib like main loop model.
+ *
+ * This module requires no threads and no main loop model. It takes care
+ * of using the fastest communication channel given the underlying OS and
+ * the requested kind of communication.
+ *
+ * The spawned process must use the Spawned module to init its communication
+ * channels.
+ *)
+
+(* This is the control panel for managed processes *)
+module type Control = sig
+ type handle
+
+ val kill : handle -> unit
+ val stats : handle -> Gc.stat
+ val wait : handle -> Unix.process_status
+ val unixpid : handle -> int
+
+ (* What is used in debug messages *)
+ val uid : handle -> string
+
+ val is_alive : handle -> bool
+end
+
+(* Abstraction to work with both threads and main loop models *)
+module type Empty = sig end
+
+module type MainLoopModel = sig
+ type async_chan
+ type condition
+ type watch_id
+
+ val add_watch : callback:(condition list -> bool) -> async_chan -> watch_id
+ val remove_watch : watch_id -> unit
+ val read_all : async_chan -> string
+ val async_chan_of_file : Unix.file_descr -> async_chan
+ val async_chan_of_socket : Unix.file_descr -> async_chan
+end
+
+(* spawn a process and read its output asynchronously *)
+module Async(ML : MainLoopModel) : sig
+ type process
+
+ (* If the returned value is false the callback is never called again and
+ * the process is killed *)
+ type callback = ML.condition list -> read_all:(unit -> string) -> bool
+
+ val spawn :
+ ?prefer_sock:bool -> ?env:string array -> string -> string array ->
+ callback -> process * out_channel
+
+ include Control with type handle = process
+end
+
+(* spawn a process and read its output synchronously *)
+module Sync(T : Empty) : sig
+ type process
+
+ val spawn :
+ ?prefer_sock:bool -> ?env:string array -> string -> string array ->
+ process * in_channel * out_channel
+
+ include Control with type handle = process
+end
+
+(* This is exported to separate the Spawned module, that for simplicity assumes
+ * Threads so it is in a separate file *)
+type req = ReqDie | ReqStats | Hello of int * int
+val proto_version : int
+type resp = RespStats of Gc.stat
diff --git a/lib/stateid.ml b/lib/stateid.ml
new file mode 100644
index 00000000..59cf206e
--- /dev/null
+++ b/lib/stateid.ml
@@ -0,0 +1,50 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+type t = int
+let initial = 1
+let dummy = 0
+let fresh, in_range =
+ let cur = ref initial in
+ (fun () -> incr cur; !cur), (fun id -> id >= 0 && id <= !cur)
+let to_string = string_of_int
+let of_int id = assert(in_range id); id
+let to_int id = id
+let newer_than id1 id2 = id1 > id2
+
+let of_xml = function
+ | Element ("state_id",["val",i],[]) ->
+ let id = int_of_string i in
+ (* Coqide too to parse ids too, but cannot check if they are valid.
+ * Hence we check for validity only if we are an ide slave. *)
+ if !Flags.ide_slave then assert(in_range id);
+ id
+ | _ -> raise (Invalid_argument "to_state_id")
+let to_xml i = Element ("state_id",["val",string_of_int i],[])
+
+let state_id_info : (t * t) Exninfo.t = Exninfo.make ()
+let add exn ?(valid = initial) id =
+ Exninfo.add exn state_id_info (valid, id)
+let get exn = Exninfo.get exn state_id_info
+
+let equal = Int.equal
+let compare = Int.compare
+
+module Set = Set.Make(struct type t = int let compare = compare end)
+
+type ('a,'b) request = {
+ exn_info : t * t;
+ stop : t;
+ document : 'b;
+ loc : Loc.t;
+ uuid : 'a;
+ name : string
+}
+
diff --git a/lib/stateid.mli b/lib/stateid.mli
new file mode 100644
index 00000000..2c12c30c
--- /dev/null
+++ b/lib/stateid.mli
@@ -0,0 +1,45 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+type t
+
+val equal : t -> t -> bool
+val compare : t -> t -> int
+
+module Set : Set.S with type elt = t
+
+val initial : t
+val dummy : t
+val fresh : unit -> t
+val to_string : t -> string
+val of_int : int -> t
+val to_int : t -> int
+val newer_than : t -> t -> bool
+
+(* XML marshalling *)
+val to_xml : t -> xml
+val of_xml : xml -> t
+
+(* Attaches to an exception the concerned state id, plus an optional
+ * state id that is a valid state id before the error.
+ * Backtracking to the valid id is safe.
+ * The initial_state_id is assumed to be safe. *)
+val add : Exninfo.info -> ?valid:t -> t -> Exninfo.info
+val get : Exninfo.info -> (t * t) option
+
+type ('a,'b) request = {
+ exn_info : t * t;
+ stop : t;
+ document : 'b;
+ loc : Loc.t;
+ uuid : 'a;
+ name : string
+}
+
diff --git a/lib/store.ml b/lib/store.ml
index 28eb65c8..a1788f7d 100644
--- a/lib/store.ml
+++ b/lib/store.ml
@@ -6,56 +6,86 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(*** This module implements an "untyped store", in this particular case we
- see it as an extensible record whose fields are left unspecified. ***)
+(** This module implements an "untyped store", in this particular case
+ we see it as an extensible record whose fields are left
+ unspecified. ***)
-(* We give a short implementation of a universal type. This is mostly equivalent
- to what is proposed by module Dyn.ml, except that it requires no explicit tag. *)
-module type Universal = sig
- type t
-
- type 'a etype = {
- put : 'a -> t ;
- get : t -> 'a option
- }
+(** We use a dynamic "name" allocator. But if we needed to serialise
+ stores, we might want something static to avoid troubles with
+ plugins order. *)
- val embed : unit -> 'a etype
+module type T =
+sig
end
-(* We use a dynamic "name" allocator. But if we needed to serialise stores, we
-might want something static to avoid troubles with plugins order. *)
+module type S =
+sig
+ type t
+ type 'a field
+ val empty : t
+ val set : t -> 'a field -> 'a -> t
+ val get : t -> 'a field -> 'a option
+ val remove : t -> 'a field -> t
+ val merge : t -> t -> t
+ val field : unit -> 'a field
+end
-let next =
- let count = ref 0 in fun () ->
- let n = !count in
- incr count;
- n
+module Make (M : T) : S =
+struct
-type t = Obj.t Util.Intmap.t
+ let next =
+ let count = ref 0 in fun () ->
+ let n = !count in
+ incr count;
+ n
-module Field = struct
- type 'a field = {
- set : 'a -> t -> t ;
- get : t -> 'a option ;
- remove : t -> t
- }
- type 'a t = 'a field
-end
+ type t = Obj.t option array
+ (** Store are represented as arrays. For small values, which is typicial,
+ is slightly quicker than other implementations. *)
+
+type 'a field = int
+
+let allocate len : t = Array.make len None
+
+let empty : t = [||]
-open Field
-
-let empty = Util.Intmap.empty
-
-let field () =
- let fid = next () in
- let set a s =
- Util.Intmap.add fid (Obj.repr a) s
- in
- let get s =
- try Some (Obj.obj (Util.Intmap.find fid s))
- with Not_found -> None
- in
- let remove s =
- Util.Intmap.remove fid s
- in
- { set = set ; get = get ; remove = remove }
+let set (s : t) (i : 'a field) (v : 'a) : t =
+ let len = Array.length s in
+ let nlen = if i < len then len else succ i in
+ let () = assert (0 <= i) in
+ let ans = allocate nlen in
+ Array.blit s 0 ans 0 len;
+ Array.unsafe_set ans i (Some (Obj.repr v));
+ ans
+
+let get (s : t) (i : 'a field) : 'a option =
+ let len = Array.length s in
+ if len <= i then None
+ else Obj.magic (Array.unsafe_get s i)
+
+let remove (s : t) (i : 'a field) =
+ let len = Array.length s in
+ let () = assert (0 <= i) in
+ let ans = allocate len in
+ Array.blit s 0 ans 0 len;
+ if i < len then Array.unsafe_set ans i None;
+ ans
+
+let merge (s1 : t) (s2 : t) : t =
+ let len1 = Array.length s1 in
+ let len2 = Array.length s2 in
+ let nlen = if len1 < len2 then len2 else len1 in
+ let ans = allocate nlen in
+ (** Important: No more allocation from here. *)
+ Array.blit s2 0 ans 0 len2;
+ for i = 0 to pred len1 do
+ let v = Array.unsafe_get s1 i in
+ match v with
+ | None -> ()
+ | Some _ -> Array.unsafe_set ans i v
+ done;
+ ans
+
+let field () = next ()
+
+end
diff --git a/lib/store.mli b/lib/store.mli
index 5df0c99a..8eab314e 100644
--- a/lib/store.mli
+++ b/lib/store.mli
@@ -9,17 +9,38 @@
(*** This module implements an "untyped store", in this particular case we
see it as an extensible record whose fields are left unspecified. ***)
-type t
-
-module Field : sig
- type 'a field = {
- set : 'a -> t -> t ;
- get : t -> 'a option ;
- remove : t -> t
- }
- type 'a t = 'a field
+module type T =
+sig
+(** FIXME: Waiting for first-class modules... *)
end
-val empty : t
+module type S =
+sig
+ type t
+ (** Type of stores *)
-val field : unit -> 'a Field.field
+ type 'a field
+ (** Type of field of such stores *)
+
+ val empty : t
+ (** Empty store *)
+
+ val set : t -> 'a field -> 'a -> t
+ (** Set a field *)
+
+ val get : t -> 'a field -> 'a option
+ (** Get the value of a field, if any *)
+
+ val remove : t -> 'a field -> t
+ (** Unset the value of the field *)
+
+ val merge : t -> t -> t
+ (** [merge s1 s2] adds all the fields of [s1] into [s2]. *)
+
+ val field : unit -> 'a field
+ (** Create a new field *)
+
+end
+
+module Make (M : T) : S
+(** Create a new store type. *)
diff --git a/lib/system.ml b/lib/system.ml
index 8f436366..73095f9c 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -9,126 +9,10 @@
(* $Id$ *)
open Pp
+open Errors
open Util
open Unix
-(* Expanding shell variables and home-directories *)
-
-let safe_getenv_def var def =
- try
- Sys.getenv var
- with Not_found ->
- warning ("Environment variable "^var^" not found: using '"^def^"' .");
- flush_all ();
- def
-
-let getenv_else s dft = try Sys.getenv s with Not_found -> dft
-
-(* On win32, the home directory is probably not in $HOME, but in
- some other environment variable *)
-
-let home =
- try Sys.getenv "HOME" with Not_found ->
- try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
- try Sys.getenv "USERPROFILE" with Not_found ->
- warning ("Cannot determine user home directory, using '.' .");
- flush_all ();
- Filename.current_dir_name
-
-let safe_getenv n = safe_getenv_def n ("$"^n)
-
-let rec expand_atom s i =
- let l = String.length s in
- if i<l && (is_digit s.[i] or is_letter s.[i] or s.[i] = '_')
- then expand_atom s (i+1)
- else i
-
-let rec expand_macros s i =
- let l = String.length s in
- if i=l then s else
- match s.[i] with
- | '$' ->
- let n = expand_atom s (i+1) in
- let v = safe_getenv (String.sub s (i+1) (n-i-1)) in
- let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in
- expand_macros s (i + String.length v)
- | '~' when i = 0 ->
- let n = expand_atom s (i+1) in
- let v =
- if n=i+1 then home
- else (getpwnam (String.sub s (i+1) (n-i-1))).pw_dir
- in
- let s = v^(String.sub s n (l-n)) in
- expand_macros s (String.length v)
- | c -> expand_macros s (i+1)
-
-let expand_path_macros s = expand_macros s 0
-
-(* Files and load path. *)
-
-type physical_path = string
-type load_path = physical_path list
-
-let physical_path_of_string s = s
-let string_of_physical_path p = p
-
-(*
- * Split a path into a list of directories. A one-liner with Str, but Coq
- * doesn't seem to use this library at all, so here is a slighly longer version.
- *)
-
-let lpath_from_path path path_separator =
- let n = String.length path in
- let rec aux i l =
- if i < n then
- let j =
- try String.index_from path i path_separator
- with Not_found -> n
- in
- let dir = String.sub path i (j-i) in
- aux (j+1) (dir::l)
- else
- l
- in List.rev (aux 0 [])
-
-(* Hints to partially detects if two paths refer to the same repertory *)
-let rec remove_path_dot p =
- let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
- let n = String.length curdir in
- let l = String.length p in
- if l > n && String.sub p 0 n = curdir then
- let n' =
- let sl = String.length Filename.dir_sep in
- let i = ref n in
- while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
- remove_path_dot (String.sub p n' (l - n'))
- else
- p
-
-let strip_path p =
- let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
- let n = String.length cwd in
- let l = String.length p in
- if l > n && String.sub p 0 n = cwd then
- let n' =
- let sl = String.length Filename.dir_sep in
- let i = ref n in
- while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
- remove_path_dot (String.sub p n' (l - n'))
- else
- remove_path_dot p
-
-let canonical_path_name p =
- let current = Sys.getcwd () in
- try
- Sys.chdir p;
- let p' = Sys.getcwd () in
- Sys.chdir current;
- p'
- with Sys_error _ ->
- (* We give up to find a canonical name and just simplify it... *)
- strip_path p
-
(* All subdirectories, recursively *)
let exists_dir dir =
@@ -139,9 +23,9 @@ let skipped_dirnames = ref ["CVS"; "_darcs"]
let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames
let ok_dirname f =
- f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) &&
- try ignore (check_ident f); true
- with e when e <> Sys.Break -> false
+ not (String.is_empty f) && f.[0] != '.' &&
+ not (String.List.mem f !skipped_dirnames) &&
+ (match Unicode.ident_refutation f with None -> true | _ -> false)
let all_subdirs ~unix_path:root =
let l = ref [] in
@@ -154,11 +38,13 @@ let all_subdirs ~unix_path:root =
if ok_dirname f then
let file = Filename.concat dir f in
try
- if (stat file).st_kind = S_DIR then begin
- let newrel = rel@[f] in
+ begin match (stat file).st_kind with
+ | S_DIR ->
+ let newrel = rel @ [f] in
add file newrel;
traverse file newrel
- end
+ | _ -> ()
+ end
with Unix_error (e,s1,s2) -> ()
done
with End_of_file ->
@@ -167,28 +53,43 @@ let all_subdirs ~unix_path:root =
if exists_dir root then traverse root [];
List.rev !l
+let rec search paths test =
+ match paths with
+ | [] -> []
+ | lpe :: rem -> test lpe @ search rem test
+
let where_in_path ?(warn=true) path filename =
- let rec search = function
- | lpe :: rem ->
- let f = Filename.concat lpe filename in
- if Sys.file_exists f
- then (lpe,f) :: search rem
- else search rem
- | [] -> [] in
- let rec check_and_warn l =
- match l with
- | [] -> raise Not_found
- | (lpe, f) :: l' ->
- if warn & l' <> [] then
- msg_warning
- (str filename ++ str " has been found in" ++ spc () ++
- hov 0 (str "[ " ++
- hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon())
- (fun (lpe,_) -> str lpe) l)
- ++ str " ];") ++ fnl () ++
- str "loading " ++ str f);
- (lpe, f) in
- check_and_warn (search path)
+ let check_and_warn l = match l with
+ | [] -> raise Not_found
+ | (lpe, f) :: l' ->
+ let () = match l' with
+ | _ :: _ when warn ->
+ msg_warning
+ (str filename ++ str " has been found in" ++ spc () ++
+ hov 0 (str "[ " ++
+ hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon())
+ (fun (lpe,_) -> str lpe) l)
+ ++ str " ];") ++ fnl () ++
+ str "loading " ++ str f)
+ | _ -> ()
+ in
+ (lpe, f)
+ in
+ check_and_warn (search path (fun lpe ->
+ let f = Filename.concat lpe filename in
+ if Sys.file_exists f then [lpe,f] else []))
+
+let where_in_path_rex path rex =
+ search path (fun lpe ->
+ try
+ let files = Sys.readdir lpe in
+ CList.map_filter (fun name ->
+ try
+ ignore(Str.search_forward rex name 0);
+ Some (lpe,Filename.concat lpe name)
+ with Not_found -> None)
+ (Array.to_list files)
+ with Sys_error _ -> [])
let find_file_in_path ?(warn=true) paths filename =
if not (Filename.is_implicit filename) then
@@ -209,56 +110,87 @@ let is_in_path lpath filename =
try ignore (where_in_path ~warn:false lpath filename); true
with Not_found -> false
-let path_separator = if Sys.os_type = "Unix" then ':' else ';'
-
let is_in_system_path filename =
- let path = try Sys.getenv "PATH"
+ let path = try Sys.getenv "PATH"
with Not_found -> error "system variable PATH not found" in
- let lpath = lpath_from_path path path_separator in
+ let lpath = CUnix.path_to_list path in
is_in_path lpath filename
-let make_suffix name suffix =
- if Filename.check_suffix name suffix then name else (name ^ suffix)
-
-let file_readable_p name =
- try access name [R_OK];true with Unix_error (_, _, _) -> false
-
let open_trapping_failure name =
try open_out_bin name
- with e when e <> Sys.Break -> error ("Can't open " ^ name)
+ with e when Errors.noncritical e -> error ("Can't open " ^ name)
let try_remove filename =
try Sys.remove filename
- with e when e <> Sys.Break ->
- msgnl (str"Warning: " ++ str"Could not remove file " ++
- str filename ++ str" which is corrupted!" )
+ with e when Errors.noncritical e ->
+ msg_warning
+ (str"Could not remove file " ++ str filename ++ str" which is corrupted!")
-let marshal_out ch v = Marshal.to_channel ch v []
+let error_corrupted file s = error (file ^": " ^ s ^ ". Try to rebuild it.")
+
+let input_binary_int f ch =
+ try input_binary_int ch
+ with
+ | End_of_file -> error_corrupted f "premature end of file"
+ | Failure s -> error_corrupted f s
+let output_binary_int ch x = output_binary_int ch x; flush ch
+
+let marshal_out ch v = Marshal.to_channel ch v []; flush ch
let marshal_in filename ch =
try Marshal.from_channel ch
with
- | End_of_file -> error "corrupted file: reached end of file"
- | Failure _ (* e.g. "truncated object" *) ->
- error (filename ^ " is corrupted, try to rebuild it.")
+ | End_of_file -> error_corrupted filename "premature end of file"
+ | Failure s -> error_corrupted filename s
+
+let digest_out = Digest.output
+let digest_in filename ch =
+ try Digest.input ch
+ with
+ | End_of_file -> error_corrupted filename "premature end of file"
+ | Failure s -> error_corrupted filename s
+
+let marshal_out_segment f ch v =
+ let start = pos_out ch in
+ output_binary_int ch 0; (* dummy value for stop *)
+ marshal_out ch v;
+ let stop = pos_out ch in
+ seek_out ch start;
+ output_binary_int ch stop;
+ seek_out ch stop;
+ digest_out ch (Digest.file f)
+
+let marshal_in_segment f ch =
+ let stop = (input_binary_int f ch : int) in
+ let v = marshal_in f ch in
+ let digest = digest_in f ch in
+ v, stop, digest
+
+let skip_in_segment f ch =
+ let stop = (input_binary_int f ch : int) in
+ seek_in ch stop;
+ stop, digest_in f ch
exception Bad_magic_number of string
-let raw_extern_intern magic suffix =
- let extern_state name =
- let filename = make_suffix name suffix in
+let raw_extern_intern magic =
+ let extern_state filename =
let channel = open_trapping_failure filename in
output_binary_int channel magic;
- filename,channel
+ filename, channel
and intern_state filename =
- let channel = open_in_bin filename in
- if input_binary_int channel <> magic then
- raise (Bad_magic_number filename);
- channel
+ try
+ let channel = open_in_bin filename in
+ if not (Int.equal (input_binary_int filename channel) magic) then
+ raise (Bad_magic_number filename);
+ channel
+ with
+ | End_of_file -> error_corrupted filename "premature end of file"
+ | Failure s | Sys_error s -> error_corrupted filename s
in
(extern_state,intern_state)
-let extern_intern ?(warn=true) magic suffix =
- let (raw_extern,raw_intern) = raw_extern_intern magic suffix in
+let extern_intern ?(warn=true) magic =
+ let (raw_extern,raw_intern) = raw_extern_intern magic in
let extern_state name val_0 =
try
let (filename,channel) = raw_extern name in
@@ -266,11 +198,13 @@ let extern_intern ?(warn=true) magic suffix =
marshal_out channel val_0;
close_out channel
with reraise ->
- begin try_remove filename; raise reraise end
+ let reraise = Errors.push reraise in
+ let () = try_remove filename in
+ iraise reraise
with Sys_error s -> error ("System error: " ^ s)
and intern_state paths name =
try
- let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in
+ let _,filename = find_file_in_path ~warn paths name in
let channel = raw_intern filename in
let v = marshal_in filename channel in
close_in channel;
@@ -284,79 +218,47 @@ let with_magic_number_check f a =
try f a
with Bad_magic_number fname ->
errorlabstrm "with_magic_number_check"
- (str"File " ++ str fname ++ strbrk" has bad magic number." ++ spc () ++
+ (str"File " ++ str fname ++ strbrk" has bad magic number." ++ spc () ++
strbrk "It is corrupted or was compiled with another version of Coq.")
-(* Communication through files with another executable *)
-
-let connect writefun readfun com =
- let name = Filename.basename com in
- let tmp_to = Filename.temp_file ("coq-"^name^"-in") ".xml" in
- let tmp_from = Filename.temp_file ("coq-"^name^"-out") ".xml" in
- let ch_to_in,ch_to_out =
- try open_in tmp_to, open_out tmp_to
- with Sys_error s -> error ("Cannot set connection to "^com^"("^s^")") in
- let ch_from_in,ch_from_out =
- try open_in tmp_from, open_out tmp_from
- with Sys_error s ->
- close_out ch_to_out; close_in ch_to_in;
- error ("Cannot set connection from "^com^"("^s^")") in
- writefun ch_to_out;
- close_out ch_to_out;
- let pid =
- let ch_to' = Unix.descr_of_in_channel ch_to_in in
- let ch_from' = Unix.descr_of_out_channel ch_from_out in
- try Unix.create_process com [|com|] ch_to' ch_from' Unix.stdout
- with Unix.Unix_error (err,_,_) ->
- close_in ch_to_in; close_in ch_from_in; close_out ch_from_out;
- unlink tmp_from; unlink tmp_to;
- error ("Cannot execute "^com^"("^(Unix.error_message err)^")") in
- close_in ch_to_in;
- close_out ch_from_out;
- (match snd (Unix.waitpid [] pid) with
- | Unix.WEXITED 127 -> error (com^": cannot execute")
- | Unix.WEXITED 0 -> ()
- | _ -> error (com^" exited abnormally"));
- let a = readfun ch_from_in in
- close_in ch_from_in;
- unlink tmp_from;
- unlink tmp_to;
- a
-
-let run_command converter f c =
- let result = Buffer.create 127 in
- let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
- let buff = String.make 127 ' ' in
- let buffe = String.make 127 ' ' in
- let n = ref 0 in
- let ne = ref 0 in
-
- while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ;
- !n+ !ne <> 0
- do
- let r = converter (String.sub buff 0 !n) in
- f r;
- Buffer.add_string result r;
- let r = converter (String.sub buffe 0 !ne) in
- f r;
- Buffer.add_string result r
- done;
- (Unix.close_process_full (cin,cout,cerr), Buffer.contents result)
-
(* Time stamps. *)
type time = float * float * float
let get_time () =
- let t = times () in
- (time(), t.tms_utime, t.tms_stime)
+ let t = Unix.times () in
+ (Unix.gettimeofday(), t.tms_utime, t.tms_stime)
-let time_difference (t1,_,_) (t2,_,_) = t2 -. t1
+(* Keep only 3 significant digits *)
+let round f = (floor (f *. 1e3)) *. 1e-3
+
+let time_difference (t1,_,_) (t2,_,_) = round (t2 -. t1)
let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) =
- real (stopreal -. startreal) ++ str " secs " ++
+ real (round (stopreal -. startreal)) ++ str " secs " ++
str "(" ++
- real ((-.) ustop ustart) ++ str "u" ++
+ real (round (ustop -. ustart)) ++ str "u" ++
str "," ++
- real ((-.) sstop sstart) ++ str "s" ++
+ real (round (sstop -. sstart)) ++ str "s" ++
str ")"
+
+let with_time time f x =
+ let tstart = get_time() in
+ let msg = if time then "" else "Finished transaction in " in
+ try
+ let y = f x in
+ let tend = get_time() in
+ let msg2 = if time then "" else " (successful)" in
+ msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2);
+ y
+ with e ->
+ let tend = get_time() in
+ let msg = if time then "" else "Finished failing transaction in " in
+ let msg2 = if time then "" else " (failure)" in
+ msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2);
+ raise e
+
+let process_id () =
+ if Flags.async_proofs_is_worker () then !Flags.async_proofs_worker_id
+ else Printf.sprintf "master:%d" (Thread.id (Thread.self ()))
+
diff --git a/lib/system.mli b/lib/system.mli
index b56e65a4..a3d66d57 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -1,12 +1,12 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(** System utilities *)
+(** {5 Coqtop specific system utilities} *)
(** {6 Files and load paths} *)
@@ -14,63 +14,50 @@
given by the user. For efficiency, we keep the full path (field
[directory]), the root path and the path relative to the root. *)
-type physical_path = string
-type load_path = physical_path list
-
-val canonical_path_name : string -> string
-
val exclude_search_in_dirname : string -> unit
-val all_subdirs : unix_path:string -> (physical_path * string list) list
-val is_in_path : load_path -> string -> bool
+val all_subdirs : unix_path:string -> (CUnix.physical_path * string list) list
+val is_in_path : CUnix.load_path -> string -> bool
val is_in_system_path : string -> bool
-val where_in_path : ?warn:bool -> load_path -> string -> physical_path * string
-
-val physical_path_of_string : string -> physical_path
-val string_of_physical_path : physical_path -> string
-
-val make_suffix : string -> string -> string
-val file_readable_p : string -> bool
-
-val expand_path_macros : string -> string
-val getenv_else : string -> string -> string
-val home : string
+val where_in_path :
+ ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string
+val where_in_path_rex :
+ CUnix.load_path -> Str.regexp -> (CUnix.physical_path * string) list
val exists_dir : string -> bool
val find_file_in_path :
- ?warn:bool -> load_path -> string -> physical_path * string
+ ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string
(** {6 I/O functions } *)
(** Generic input and output functions, parameterized by a magic number
and a suffix. The intern functions raise the exception [Bad_magic_number]
when the check fails, with the full file name. *)
-val marshal_out : out_channel -> 'a -> unit
-val marshal_in : string -> in_channel -> 'a
-
exception Bad_magic_number of string
-val raw_extern_intern : int -> string ->
+val raw_extern_intern : int ->
(string -> string * out_channel) * (string -> in_channel)
-val extern_intern : ?warn:bool -> int -> string ->
- (string -> 'a -> unit) * (load_path -> string -> 'a)
+val extern_intern : ?warn:bool -> int ->
+ (string -> 'a -> unit) * (CUnix.load_path -> string -> 'a)
val with_magic_number_check : ('a -> 'b) -> 'a -> 'b
-(** {6 Sending/receiving once with external executable } *)
+(** Clones of Marshal.to_channel (with flush) and
+ Marshal.from_channel (with nice error message) *)
+
+val marshal_out : out_channel -> 'a -> unit
+val marshal_in : string -> in_channel -> 'a
-val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a
+(** Clones of Digest.output and Digest.input (with nice error message) *)
-(** {6 Executing commands } *)
-(** [run_command converter f com] launches command [com], and returns
- the contents of stdout and stderr that have been processed with
- [converter]; the processed contents of stdout and stderr is also
- passed to [f] *)
+val digest_out : out_channel -> Digest.t -> unit
+val digest_in : string -> in_channel -> Digest.t
-val run_command : (string -> string) -> (string -> unit) -> string ->
- Unix.process_status * string
+val marshal_out_segment : string -> out_channel -> 'a -> unit
+val marshal_in_segment : string -> in_channel -> 'a * int * Digest.t
+val skip_in_segment : string -> in_channel -> int * Digest.t
(** {6 Time stamps.} *)
@@ -79,3 +66,8 @@ type time
val get_time : unit -> time
val time_difference : time -> time -> float (** in seconds *)
val fmt_time_difference : time -> time -> Pp.std_ppcmds
+
+val with_time : bool -> ('a -> 'b) -> 'a -> 'b
+
+(** {6 Name of current process.} *)
+val process_id : unit -> string
diff --git a/lib/terminal.ml b/lib/terminal.ml
new file mode 100644
index 00000000..1e6c2557
--- /dev/null
+++ b/lib/terminal.ml
@@ -0,0 +1,284 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type color = [
+ `DEFAULT
+| `BLACK
+| `RED
+| `GREEN
+| `YELLOW
+| `BLUE
+| `MAGENTA
+| `CYAN
+| `WHITE
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE
+| `INDEX of int
+| `RGB of (int * int * int)
+]
+
+type style = {
+ fg_color : color option;
+ bg_color : color option;
+ bold : bool option;
+ italic : bool option;
+ underline : bool option;
+ negative : bool option;
+}
+
+let set o1 o2 = match o1 with
+| None -> o2
+| Some _ ->
+ match o2 with
+ | None -> o1
+ | Some _ -> o2
+
+let default = {
+ fg_color = None;
+ bg_color = None;
+ bold = None;
+ italic = None;
+ underline = None;
+ negative = None;
+}
+
+let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style () =
+ let st = match style with
+ | None -> default
+ | Some st -> st
+ in
+ {
+ fg_color = set st.fg_color fg_color;
+ bg_color = set st.bg_color bg_color;
+ bold = set st.bold bold;
+ italic = set st.italic italic;
+ underline = set st.underline underline;
+ negative = set st.negative negative;
+ }
+
+let merge s1 s2 =
+ {
+ fg_color = set s1.fg_color s2.fg_color;
+ bg_color = set s1.bg_color s2.bg_color;
+ bold = set s1.bold s2.bold;
+ italic = set s1.italic s2.italic;
+ underline = set s1.underline s2.underline;
+ negative = set s1.negative s2.negative;
+ }
+
+let base_color = function
+| `DEFAULT -> 9
+| `BLACK -> 0
+| `RED -> 1
+| `GREEN -> 2
+| `YELLOW -> 3
+| `BLUE -> 4
+| `MAGENTA -> 5
+| `CYAN -> 6
+| `WHITE -> 7
+| `LIGHT_BLACK -> 0
+| `LIGHT_RED -> 1
+| `LIGHT_GREEN -> 2
+| `LIGHT_YELLOW -> 3
+| `LIGHT_BLUE -> 4
+| `LIGHT_MAGENTA -> 5
+| `LIGHT_CYAN -> 6
+| `LIGHT_WHITE -> 7
+| _ -> invalid_arg "base_color"
+
+let extended_color off = function
+| `INDEX i -> [off + 8; 5; i]
+| `RGB (r, g, b) -> [off + 8; 2; r; g; b]
+| _ -> invalid_arg "extended_color"
+
+let is_light = function
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE -> true
+| _ -> false
+
+let is_extended = function
+| `INDEX _ | `RGB _ -> true
+| _ -> false
+
+let eval st =
+ let fg = match st.fg_color with
+ | None -> []
+ | Some c ->
+ if is_light c then [90 + base_color c]
+ else if is_extended c then extended_color 30 c
+ else [30 + base_color c]
+ in
+ let bg = match st.bg_color with
+ | None -> []
+ | Some c ->
+ if is_light c then [100 + base_color c]
+ else if is_extended c then extended_color 40 c
+ else [40 + base_color c]
+ in
+ let bold = match st.bold with
+ | None -> []
+ | Some true -> [1]
+ | Some false -> [22]
+ in
+ let italic = match st.italic with
+ | None -> []
+ | Some true -> [3]
+ | Some false -> [23]
+ in
+ let underline = match st.underline with
+ | None -> []
+ | Some true -> [4]
+ | Some false -> [24]
+ in
+ let negative = match st.negative with
+ | None -> []
+ | Some true -> [7]
+ | Some false -> [27]
+ in
+ let tags = fg @ bg @ bold @ italic @ underline @ negative in
+ let tags = List.map string_of_int tags in
+ Printf.sprintf "\027[%sm" (String.concat ";" tags)
+
+let reset = "\027[0m"
+
+let reset_style = {
+ fg_color = Some `DEFAULT;
+ bg_color = Some `DEFAULT;
+ bold = Some false;
+ italic = Some false;
+ underline = Some false;
+ negative = Some false;
+}
+
+let has_style t = Unix.isatty t
+
+let split c s =
+ let len = String.length s in
+ let rec split n =
+ try
+ let pos = String.index_from s n c in
+ let dir = String.sub s n (pos-n) in
+ dir :: split (succ pos)
+ with
+ | Not_found -> [String.sub s n (len-n)]
+ in
+ if len = 0 then [] else split 0
+
+let check_char i = if i < 0 || i > 255 then invalid_arg "check_char"
+
+let parse_color off rem = match off with
+| 0 -> (`BLACK, rem)
+| 1 -> (`RED, rem)
+| 2 -> (`GREEN, rem)
+| 3 -> (`YELLOW, rem)
+| 4 -> (`BLUE, rem)
+| 5 -> (`MAGENTA, rem)
+| 6 -> (`CYAN, rem)
+| 7 -> (`WHITE, rem)
+| 9 -> (`DEFAULT, rem)
+| 8 ->
+ begin match rem with
+ | 5 :: i :: rem ->
+ check_char i;
+ (`INDEX i, rem)
+ | 2 :: r :: g :: b :: rem ->
+ check_char r;
+ check_char g;
+ check_char b;
+ (`RGB (r, g, b), rem)
+ | _ -> invalid_arg "parse_color"
+ end
+| _ -> invalid_arg "parse_color"
+
+let set_light = function
+| `BLACK -> `LIGHT_BLACK
+| `RED -> `LIGHT_RED
+| `GREEN -> `LIGHT_GREEN
+| `YELLOW -> `LIGHT_YELLOW
+| `BLUE -> `LIGHT_BLUE
+| `MAGENTA -> `LIGHT_MAGENTA
+| `CYAN -> `LIGHT_CYAN
+| `WHITE -> `LIGHT_WHITE
+| _ -> invalid_arg "parse_color"
+
+let rec parse_style style = function
+| [] -> style
+| 0 :: rem ->
+ let style = merge style reset_style in
+ parse_style style rem
+| 1 :: rem ->
+ let style = make ~style ~bold:true () in
+ parse_style style rem
+| 3 :: rem ->
+ let style = make ~style ~italic:true () in
+ parse_style style rem
+| 4 :: rem ->
+ let style = make ~style ~underline:true () in
+ parse_style style rem
+| 7 :: rem ->
+ let style = make ~style ~negative:true () in
+ parse_style style rem
+| 22 :: rem ->
+ let style = make ~style ~bold:false () in
+ parse_style style rem
+| 23 :: rem ->
+ let style = make ~style ~italic:false () in
+ parse_style style rem
+| 24 :: rem ->
+ let style = make ~style ~underline:false () in
+ parse_style style rem
+| 27 :: rem ->
+ let style = make ~style ~negative:false () in
+ parse_style style rem
+| code :: rem when (30 <= code && code < 40) ->
+ let color, rem = parse_color (code mod 10) rem in
+ let style = make ~style ~fg_color:color () in
+ parse_style style rem
+| code :: rem when (40 <= code && code < 50) ->
+ let color, rem = parse_color (code mod 10) rem in
+ let style = make ~style ~bg_color:color () in
+ parse_style style rem
+| code :: rem when (90 <= code && code < 100) ->
+ let color, rem = parse_color (code mod 10) rem in
+ let style = make ~style ~fg_color:(set_light color) () in
+ parse_style style rem
+| code :: rem when (100 <= code && code < 110) ->
+ let color, rem = parse_color (code mod 10) rem in
+ let style = make ~style ~bg_color:(set_light color) () in
+ parse_style style rem
+| _ :: rem -> parse_style style rem
+
+(** Parse LS_COLORS-like strings *)
+let parse s =
+ let defs = split ':' s in
+ let fold accu s = match split '=' s with
+ | [name; attrs] ->
+ let attrs = split ';' attrs in
+ let accu =
+ try
+ let attrs = List.map int_of_string attrs in
+ let attrs = parse_style (make ()) attrs in
+ (name, attrs) :: accu
+ with _ -> accu
+ in
+ accu
+ | _ -> accu
+ in
+ List.fold_left fold [] defs
diff --git a/lib/terminal.mli b/lib/terminal.mli
new file mode 100644
index 00000000..f308ede3
--- /dev/null
+++ b/lib/terminal.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type color = [
+ `DEFAULT
+| `BLACK
+| `RED
+| `GREEN
+| `YELLOW
+| `BLUE
+| `MAGENTA
+| `CYAN
+| `WHITE
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE
+| `INDEX of int
+| `RGB of (int * int * int)
+]
+
+type style = {
+ fg_color : color option;
+ bg_color : color option;
+ bold : bool option;
+ italic : bool option;
+ underline : bool option;
+ negative : bool option;
+}
+
+val make : ?fg_color:color -> ?bg_color:color ->
+ ?bold:bool -> ?italic:bool -> ?underline:bool ->
+ ?negative:bool -> ?style:style -> unit -> style
+(** Create a style from the given flags. It is derived from the optional
+ [style] argument if given. *)
+
+val merge : style -> style -> style
+(** [merge s1 s2] returns [s1] with all defined values of [s2] overwritten. *)
+
+val eval : style -> string
+(** Generate an escape sequence from a style. *)
+
+val reset : string
+(** This escape sequence resets all attributes. *)
+
+val has_style : Unix.file_descr -> bool
+(** Whether an output file descriptor handles styles. Very heuristic, only
+ checks it is a terminal. *)
+
+val parse : string -> (string * style) list
+(** Parse strings describing terminal styles in the LS_COLORS syntax. For
+ robustness, ignore meaningless entries and drops undefined styles. *)
diff --git a/lib/trie.ml b/lib/trie.ml
new file mode 100644
index 00000000..e369e6ad
--- /dev/null
+++ b/lib/trie.ml
@@ -0,0 +1,89 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module type S =
+sig
+ type label
+ type data
+ type t
+ val empty : t
+ val get : t -> data
+ val next : t -> label -> t
+ val labels : t -> label list
+ val add : label list -> data -> t -> t
+ val remove : label list -> data -> t -> t
+ val iter : (label list -> data -> unit) -> t -> unit
+end
+
+module type Grp =
+sig
+ type t
+ val nil : t
+ val is_nil : t -> bool
+ val add : t -> t -> t
+ val sub : t -> t -> t
+end
+
+module Make (Y : Map.OrderedType) (X : Grp) =
+struct
+
+module T_codom = Map.Make(Y)
+
+type data = X.t
+type label = Y.t
+type t = Node of X.t * t T_codom.t
+
+let codom_for_all f m =
+ let fold key v accu = f v && accu in
+ T_codom.fold fold m true
+
+let empty = Node (X.nil, T_codom.empty)
+
+let next (Node (_,m)) lbl = T_codom.find lbl m
+
+let get (Node (hereset,_)) = hereset
+
+let labels (Node (_,m)) =
+ (** FIXME: this is order-dependent. Try to find a more robust presentation? *)
+ List.rev (T_codom.fold (fun x _ acc -> x::acc) m [])
+
+let is_empty_node (Node(a,b)) = (X.is_nil a) && (T_codom.is_empty b)
+
+let assure_arc m lbl =
+ if T_codom.mem lbl m then
+ m
+ else
+ T_codom.add lbl (Node (X.nil,T_codom.empty)) m
+
+let cleanse_arcs (Node (hereset,m)) =
+ let m = if codom_for_all is_empty_node m then T_codom.empty else m in
+ Node(hereset, m)
+
+let rec at_path f (Node (hereset,m)) = function
+ | [] ->
+ cleanse_arcs (Node(f hereset,m))
+ | h::t ->
+ let m = assure_arc m h in
+ cleanse_arcs (Node(hereset,
+ T_codom.add h (at_path f (T_codom.find h m) t) m))
+
+let add path v tm =
+ at_path (fun hereset -> X.add v hereset) tm path
+
+let remove path v tm =
+ at_path (fun hereset -> X.sub hereset v) tm path
+
+let iter f tlm =
+ let rec apprec pfx (Node(hereset,m)) =
+ let path = List.rev pfx in
+ f path hereset;
+ T_codom.iter (fun l tm -> apprec (l::pfx) tm) m
+ in
+ apprec [] tlm
+
+end
diff --git a/lib/trie.mli b/lib/trie.mli
new file mode 100644
index 00000000..81847485
--- /dev/null
+++ b/lib/trie.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Generic functorized trie data structure. *)
+
+module type S =
+sig
+ (** A trie is a generalization of the map data structure where the keys are
+ themselves lists. *)
+
+ type label
+ (** Keys of the trie structure are [label list]. *)
+
+ type data
+ (** Data on nodes of tries are finite sets of [data]. *)
+
+ type t
+ (** The trie data structure. Essentially a finite map with keys [label list]
+ and content [data Set.t]. *)
+
+ val empty : t
+ (** The empty trie. *)
+
+ val get : t -> data
+ (** Get the data at the current node. *)
+
+ val next : t -> label -> t
+ (** [next t lbl] returns the subtrie of [t] pointed by [lbl].
+ @raise Not_found if there is none. *)
+
+ val labels : t -> label list
+ (** Get the list of defined labels at the current node. *)
+
+ val add : label list -> data -> t -> t
+ (** [add t path v] adds [v] at path [path] in [t]. *)
+
+ val remove : label list -> data -> t -> t
+ (** [remove t path v] removes [v] from path [path] in [t]. *)
+
+ val iter : (label list -> data -> unit) -> t -> unit
+ (** Apply a function to all contents. *)
+
+end
+
+module type Grp =
+sig
+ type t
+ val nil : t
+ val is_nil : t -> bool
+ val add : t -> t -> t
+ val sub : t -> t -> t
+end
+
+module Make (Label : Set.OrderedType) (Data : Grp) : S
+ with type label = Label.t and type data = Data.t
+(** Generating functor, for a given type of labels and data. *)
diff --git a/lib/tries.ml b/lib/tries.ml
deleted file mode 100644
index 60b466b7..00000000
--- a/lib/tries.ml
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-
-
-module Make =
- functor (X : Set.OrderedType) ->
- functor (Y : Map.OrderedType) ->
-struct
- module T_dom = Fset.Make(X)
- module T_codom = Fmap.Make(Y)
-
- type t = Node of T_dom.t * t T_codom.t
-
- let codom_to_list m = T_codom.fold (fun x y l -> (x,y)::l) m []
-
- let codom_rng m = T_codom.fold (fun _ y acc -> y::acc) m []
-
- let codom_dom m = T_codom.fold (fun x _ acc -> x::acc) m []
-
- let empty = Node (T_dom.empty, T_codom.empty)
-
- let map (Node (_,m)) lbl = T_codom.find lbl m
-
- let xtract (Node (hereset,_)) = T_dom.elements hereset
-
- let dom (Node (_,m)) = codom_dom m
-
- let in_dom (Node (_,m)) lbl = T_codom.mem lbl m
-
- let is_empty_node (Node(a,b)) = (T_dom.elements a = []) & (codom_to_list b = [])
-
-let assure_arc m lbl =
- if T_codom.mem lbl m then
- m
- else
- T_codom.add lbl (Node (T_dom.empty,T_codom.empty)) m
-
-let cleanse_arcs (Node (hereset,m)) =
- let l = codom_rng m in
- Node(hereset, if List.for_all is_empty_node l then T_codom.empty else m)
-
-let rec at_path f (Node (hereset,m)) = function
- | [] ->
- cleanse_arcs (Node(f hereset,m))
- | h::t ->
- let m = assure_arc m h in
- cleanse_arcs (Node(hereset,
- T_codom.add h (at_path f (T_codom.find h m) t) m))
-
-let add tm (path,v) =
- at_path (fun hereset -> T_dom.add v hereset) tm path
-
-let rmv tm (path,v) =
- at_path (fun hereset -> T_dom.remove v hereset) tm path
-
-let app f tlm =
- let rec apprec pfx (Node(hereset,m)) =
- let path = List.rev pfx in
- T_dom.iter (fun v -> f(path,v)) hereset;
- T_codom.iter (fun l tm -> apprec (l::pfx) tm) m
- in
- apprec [] tlm
-
-let to_list tlm =
- let rec torec pfx (Node(hereset,m)) =
- let path = List.rev pfx in
- List.flatten((List.map (fun v -> (path,v)) (T_dom.elements hereset))::
- (List.map (fun (l,tm) -> torec (l::pfx) tm) (codom_to_list m)))
- in
- torec [] tlm
-
-end
diff --git a/lib/tries.mli b/lib/tries.mli
deleted file mode 100644
index 8e837677..00000000
--- a/lib/tries.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-
-
-
-
-
-module Make :
- functor (X : Set.OrderedType) ->
- functor (Y : Map.OrderedType) ->
-sig
-
- type t
-
- val empty : t
-
- (** Work on labels, not on paths. *)
-
- val map : t -> Y.t -> t
-
- val xtract : t -> X.t list
-
- val dom : t -> Y.t list
-
- val in_dom : t -> Y.t -> bool
-
- (** Work on paths, not on labels. *)
-
- val add : t -> Y.t list * X.t -> t
-
- val rmv : t -> Y.t list * X.t -> t
-
- val app : ((Y.t list * X.t) -> unit) -> t -> unit
-
- val to_list : t -> (Y.t list * X.t) list
-end
diff --git a/lib/unicode.ml b/lib/unicode.ml
new file mode 100644
index 00000000..1765e93d
--- /dev/null
+++ b/lib/unicode.ml
@@ -0,0 +1,241 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** Unicode utilities *)
+
+type status = Letter | IdentPart | Symbol
+
+exception Unsupported
+
+(* The following table stores classes of Unicode characters that
+ are used by the lexer. There are 3 different classes so 2 bits are
+ allocated for each character. We only use 16 bits over the 31 bits
+ to simplify the masking process. (This choice seems to be a good
+ trade-off between speed and space after some benchmarks.) *)
+
+(* A 256ko table, initially filled with zeros. *)
+let table = Array.make (1 lsl 17) 0
+
+(* Associate a 2-bit pattern to each status at position [i].
+ Only the 3 lowest bits of [i] are taken into account to
+ define the position of the pattern in the word.
+ Notice that pattern "00" means "undefined". *)
+let mask i = function
+ | Letter -> 1 lsl ((i land 7) lsl 1) (* 01 *)
+ | IdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *)
+ | Symbol -> 3 lsl ((i land 7) lsl 1) (* 11 *)
+
+(* Helper to reset 2 bits in a word. *)
+let reset_mask i =
+ lnot (3 lsl ((i land 7) lsl 1))
+
+(* Initialize the lookup table from a list of segments, assigning
+ a status to every character of each segment. The order of these
+ assignments is relevant: it is possible to assign status [s] to
+ a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is
+ between [c1] and [c2]. *)
+let mk_lookup_table_from_unicode_tables_for status tables =
+ List.iter
+ (List.iter
+ (fun (c1, c2) ->
+ for i = c1 to c2 do
+ table.(i lsr 3) <-
+ (table.(i lsr 3) land (reset_mask i)) lor (mask i status)
+ done))
+ tables
+
+(* Look up into the table and interpret the found pattern. *)
+let lookup x =
+ let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in
+ if v = 1 then Letter
+ else if v = 2 then IdentPart
+ else if v = 3 then Symbol
+ else raise Unsupported
+
+(* [classify] discriminates between 3 different kinds of
+ symbols based on the standard unicode classification (extracted from
+ Camomile). *)
+let classify =
+ let single c = [ (c, c) ] in
+ (* General tables. *)
+ mk_lookup_table_from_unicode_tables_for Symbol
+ [
+ Unicodetable.sm; (* Symbol, maths. *)
+ Unicodetable.sc; (* Symbol, currency. *)
+ Unicodetable.so; (* Symbol, modifier. *)
+ Unicodetable.pd; (* Punctation, dash. *)
+ Unicodetable.pc; (* Punctation, connector. *)
+ Unicodetable.pe; (* Punctation, open. *)
+ Unicodetable.ps; (* Punctation, close. *)
+ Unicodetable.pi; (* Punctation, initial quote. *)
+ Unicodetable.pf; (* Punctation, final quote. *)
+ Unicodetable.po; (* Punctation, other. *)
+ ];
+ mk_lookup_table_from_unicode_tables_for Letter
+ [
+ Unicodetable.lu; (* Letter, uppercase. *)
+ Unicodetable.ll; (* Letter, lowercase. *)
+ Unicodetable.lt; (* Letter, titlecase. *)
+ Unicodetable.lo; (* Letter, others. *)
+ ];
+ mk_lookup_table_from_unicode_tables_for IdentPart
+ [
+ Unicodetable.nd; (* Number, decimal digits. *)
+ Unicodetable.nl; (* Number, letter. *)
+ Unicodetable.no; (* Number, other. *)
+ ];
+
+ (* Workaround. Some characters seems to be missing in
+ Camomile's category tables. We add them manually. *)
+ mk_lookup_table_from_unicode_tables_for Letter
+ [
+ [(0x01D00, 0x01D7F)]; (* Phonetic Extensions. *)
+ [(0x01D80, 0x01DBF)]; (* Phonetic Extensions Suppl. *)
+ [(0x01DC0, 0x01DFF)]; (* Combining Diacritical Marks Suppl.*)
+ ];
+
+ (* Exceptions (from a previous version of this function). *)
+ mk_lookup_table_from_unicode_tables_for Symbol
+ [
+ [(0x000B2, 0x000B3)]; (* Superscript 2-3. *)
+ single 0x000B9; (* Superscript 1. *)
+ single 0x02070; (* Superscript 0. *)
+ [(0x02074, 0x02079)]; (* Superscript 4-9. *)
+ single 0x0002E; (* Dot. *)
+ ];
+ mk_lookup_table_from_unicode_tables_for Letter
+ [
+ single 0x005F; (* Underscore. *)
+ single 0x00A0; (* Non breaking space. *)
+ ];
+ mk_lookup_table_from_unicode_tables_for IdentPart
+ [
+ single 0x0027; (* Special space. *)
+ ];
+ (* Lookup *)
+ lookup
+
+exception End_of_input
+
+let utf8_of_unicode n =
+ if n < 128 then
+ String.make 1 (Char.chr n)
+ else if n < 2048 then
+ let s = String.make 2 (Char.chr (128 + n mod 64)) in
+ begin
+ s.[0] <- Char.chr (192 + n / 64);
+ s
+ end
+ else if n < 65536 then
+ let s = String.make 3 (Char.chr (128 + n mod 64)) in
+ begin
+ s.[1] <- Char.chr (128 + (n / 64) mod 64);
+ s.[0] <- Char.chr (224 + n / 4096);
+ s
+ end
+ else
+ let s = String.make 4 (Char.chr (128 + n mod 64)) in
+ begin
+ s.[2] <- Char.chr (128 + (n / 64) mod 64);
+ s.[1] <- Char.chr (128 + (n / 4096) mod 64);
+ s.[0] <- Char.chr (240 + n / 262144);
+ s
+ end
+
+let next_utf8 s i =
+ let err () = invalid_arg "utf8" in
+ let l = String.length s - i in
+ if l = 0 then raise End_of_input
+ else let a = Char.code s.[i] in if a <= 0x7F then
+ 1, a
+ else if a land 0x40 = 0 || l = 1 then err ()
+ else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err ()
+ else if a land 0x20 = 0 then
+ 2, (a land 0x1F) lsl 6 + (b land 0x3F)
+ else if l = 2 then err ()
+ else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err ()
+ else if a land 0x10 = 0 then
+ 3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F)
+ else if l = 3 then err ()
+ else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err ()
+ else if a land 0x08 = 0 then
+ 4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 +
+ (c land 0x3F) lsl 6 + (d land 0x3F)
+ else err ()
+
+(* Check the well-formedness of an identifier *)
+
+let initial_refutation j n s =
+ match classify n with
+ | Letter -> None
+ | _ ->
+ let c = String.sub s 0 j in
+ Some (false,
+ "Invalid character '"^c^"' at beginning of identifier \""^s^"\".")
+
+let trailing_refutation i j n s =
+ match classify n with
+ | Letter | IdentPart -> None
+ | _ ->
+ let c = String.sub s i j in
+ Some (false,
+ "Invalid character '"^c^"' in identifier \""^s^"\".")
+
+let ident_refutation s =
+ if s = ".." then None else try
+ let j, n = next_utf8 s 0 in
+ match initial_refutation j n s with
+ |None ->
+ begin try
+ let rec aux i =
+ let j, n = next_utf8 s i in
+ match trailing_refutation i j n s with
+ |None -> aux (i + j)
+ |x -> x
+ in aux j
+ with End_of_input -> None
+ end
+ |x -> x
+ with
+ | End_of_input -> Some (true,"The empty string is not an identifier.")
+ | Unsupported -> Some (true,s^": unsupported character in utf8 sequence.")
+ | Invalid_argument _ -> Some (true,s^": invalid utf8 sequence.")
+
+let lowercase_unicode =
+ let tree = Segmenttree.make Unicodetable.to_lower in
+ fun unicode ->
+ try
+ match Segmenttree.lookup unicode tree with
+ | `Abs c -> c
+ | `Delta d -> unicode + d
+ with Not_found -> unicode
+
+let lowercase_first_char s =
+ assert (s <> "");
+ let j, n = next_utf8 s 0 in
+ utf8_of_unicode (lowercase_unicode n)
+
+(** For extraction, we need to encode unicode character into ascii ones *)
+
+let is_basic_ascii s =
+ let ok = ref true in
+ String.iter (fun c -> if Char.code c >= 128 then ok := false) s;
+ !ok
+
+let ascii_of_ident s =
+ if is_basic_ascii s then s else
+ let i = ref 0 and out = ref "" in
+ begin try while true do
+ let j, n = next_utf8 s !i in
+ out :=
+ if n >= 128
+ then Printf.sprintf "%s__U%04x_" !out n
+ else Printf.sprintf "%s%c" !out s.[!i];
+ i := !i + j
+ done with End_of_input -> () end;
+ !out
diff --git a/lib/unicode.mli b/lib/unicode.mli
new file mode 100644
index 00000000..098f6c91
--- /dev/null
+++ b/lib/unicode.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Unicode utilities *)
+
+type status = Letter | IdentPart | Symbol
+
+exception Unsupported
+
+(** Classify a unicode char into 3 classes, or raise [Unsupported] *)
+val classify : int -> status
+
+(** Check whether a given string be used as a legal identifier.
+ - [None] means yes
+ - [Some (b,s)] means no, with explanation [s] and severity [b] *)
+val ident_refutation : string -> (bool * string) option
+
+(** First char of a string, converted to lowercase *)
+val lowercase_first_char : string -> string
+
+(** For extraction, turn a unicode string into an ascii-only one *)
+val is_basic_ascii : string -> bool
+val ascii_of_ident : string -> string
diff --git a/lib/unionfind.ml b/lib/unionfind.ml
index 300e8b0e..c44aa736 100644
--- a/lib/unionfind.ml
+++ b/lib/unionfind.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -53,7 +53,28 @@ module type PartitionSig = sig
end
-module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct
+module type SetS =
+sig
+ type t
+ type elt
+ val singleton : elt -> t
+ val union : t -> t -> t
+ val choose : t -> elt
+ val iter : (elt -> unit) -> t -> unit
+end
+
+module type MapS =
+sig
+ type key
+ type +'a t
+ val empty : 'a t
+ val find : key -> 'a t -> 'a
+ val add : key -> 'a -> 'a t -> 'a t
+ val mem : key -> 'a t -> bool
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end
+
+module Make (S:SetS)(M:MapS with type key = S.elt) = struct
type elt = S.elt
type set = S.t
@@ -101,7 +122,7 @@ module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct
let union_set s p =
try
- let x = S.min_elt s in
+ let x = S.choose s in
S.iter (fun y -> union x y p) s
with Not_found -> ()
diff --git a/lib/unionfind.mli b/lib/unionfind.mli
index 0db9ff08..310d5e2a 100644
--- a/lib/unionfind.mli
+++ b/lib/unionfind.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -51,7 +51,30 @@ module type PartitionSig = sig
end
+module type SetS =
+sig
+ type t
+ type elt
+ val singleton : elt -> t
+ val union : t -> t -> t
+ val choose : t -> elt
+ val iter : (elt -> unit) -> t -> unit
+end
+(** Minimal interface for sets, subtype of stdlib's Set. *)
+
+module type MapS =
+sig
+ type key
+ type +'a t
+ val empty : 'a t
+ val find : key -> 'a t -> 'a
+ val add : key -> 'a -> 'a t -> 'a t
+ val mem : key -> 'a t -> bool
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end
+(** Minimal interface for maps, subtype of stdlib's Map. *)
+
module Make :
- functor (S:Set.S) ->
- functor (M:Map.S with type key = S.elt) ->
+ functor (S:SetS) ->
+ functor (M:MapS with type key = S.elt) ->
PartitionSig with type elt = S.elt and type set = S.t
diff --git a/lib/util.ml b/lib/util.ml
index 4f14b83a..a8c25f74 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -6,47 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-open Pp
-open Compat
-
-(* Errors *)
-
-exception Anomaly of string * std_ppcmds (* System errors *)
-let anomaly string = raise (Anomaly(string, str string))
-let anomalylabstrm string pps = raise (Anomaly(string,pps))
-
-exception UserError of string * std_ppcmds (* User errors *)
-let error string = raise (UserError("_", str string))
-let errorlabstrm l pps = raise (UserError(l,pps))
-
-exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
-let alreadydeclared pps = raise (AlreadyDeclared(pps))
-
-let todo s = prerr_string ("TODO: "^s^"\n")
-
-exception Timeout
-
-type loc = Loc.t
-let dummy_loc = Loc.ghost
-let join_loc = Loc.merge
-let make_loc = make_loc
-let unloc = unloc
-
-(* raising located exceptions *)
-type 'a located = loc * 'a
-let anomaly_loc (loc,s,strm) = Loc.raise loc (Anomaly (s,strm))
-let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm))
-let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s)
-
-let located_fold_left f x (_,a) = f x a
-let located_iter2 f (_,a) (_,b) = f a b
-let down_located f (_,a) = f a
-
-(* Like Exc_located, but specifies the outermost file read, the filename
- associated to the location of the error, and the error itself. *)
-
-exception Error_in_file of string * (bool * string * loc) * exn
-
(* Mapping under pairs *)
let on_fst f (a,b) = (f a,b)
@@ -65,1195 +24,64 @@ let pi1 (a,_,_) = a
let pi2 (_,a,_) = a
let pi3 (_,_,a) = a
-(* Projection operator *)
-
-let down_fst f x = f (fst x)
-let down_snd f x = f (snd x)
-
(* Characters *)
-let is_letter c = (c >= 'a' && c <= 'z') or (c >= 'A' && c <= 'Z')
+let is_letter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
let is_digit c = (c >= '0' && c <= '9')
let is_ident_tail c =
- is_letter c or is_digit c or c = '\'' or c = '_'
+ is_letter c || is_digit c || c = '\'' || c = '_'
let is_blank = function
| ' ' | '\r' | '\t' | '\n' -> true
| _ -> false
-(* Strings *)
-
-let explode s =
- let rec explode_rec n =
- if n >= String.length s then
- []
- else
- String.make 1 (String.get s n) :: explode_rec (succ n)
- in
- explode_rec 0
-
-let implode sl = String.concat "" sl
-
-let strip s =
- let n = String.length s in
- let rec lstrip_rec i =
- if i < n && is_blank s.[i] then
- lstrip_rec (i+1)
- else i
- in
- let rec rstrip_rec i =
- if i >= 0 && is_blank s.[i] then
- rstrip_rec (i-1)
- else i
- in
- let a = lstrip_rec 0 and b = rstrip_rec (n-1) in
- String.sub s a (b-a+1)
-
-let drop_simple_quotes s =
- let n = String.length s in
- if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s
-
-(* substring searching... *)
-
-(* gdzie = where, co = what *)
-(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
-let rec is_sub gdzie gl gi co cl ci =
- (ci>=cl) ||
- ((String.unsafe_get gdzie gi = String.unsafe_get co ci) &&
- (is_sub gdzie gl (gi+1) co cl (ci+1)))
-
-let rec raw_str_index i gdzie l c co cl =
- (* First adapt to ocaml 3.11 new semantics of index_from *)
- if (i+cl > l) then raise Not_found;
- (* Then proceed as in ocaml < 3.11 *)
- let i' = String.index_from gdzie i c in
- if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else
- raw_str_index (i'+1) gdzie l c co cl
-
-let string_index_from gdzie i co =
- if co="" then i else
- raw_str_index i gdzie (String.length gdzie)
- (String.unsafe_get co 0) co (String.length co)
-
-let string_string_contains ~where ~what =
- try
- let _ = string_index_from where 0 what in true
- with
- Not_found -> false
-
-let plural n s = if n<>1 then s^"s" else s
-
-let ordinal n =
- let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in
- string_of_int n ^ s
-
-(* string parsing *)
-
-let split_string_at c s =
- let len = String.length s in
- let rec split n =
- try
- let pos = String.index_from s n c in
- let dir = String.sub s n (pos-n) in
- dir :: split (succ pos)
- with
- | Not_found -> [String.sub s n (len-n)]
- in
- if len = 0 then [] else split 0
-
-let parse_loadpath s =
- let l = split_string_at '/' s in
- if List.mem "" l then
- invalid_arg "parse_loadpath: find an empty dir in loadpath";
- l
-
-module Stringset = Set.Make(struct type t = string let compare = compare end)
-
-module Stringmap = Map.Make(struct type t = string let compare = compare end)
-
-type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol
-
-exception UnsupportedUtf8
-
-(* The following table stores classes of Unicode characters that
- are used by the lexer. There are 3 different classes so 2 bits are
- allocated for each character. We only use 16 bits over the 31 bits
- to simplify the masking process. (This choice seems to be a good
- trade-off between speed and space after some benchmarks.) *)
-
-(* A 256ko table, initially filled with zeros. *)
-let table = Array.create (1 lsl 17) 0
-
-(* Associate a 2-bit pattern to each status at position [i].
- Only the 3 lowest bits of [i] are taken into account to
- define the position of the pattern in the word.
- Notice that pattern "00" means "undefined". *)
-let mask i = function
- | UnicodeLetter -> 1 lsl ((i land 7) lsl 1) (* 01 *)
- | UnicodeIdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *)
- | UnicodeSymbol -> 3 lsl ((i land 7) lsl 1) (* 11 *)
-
-(* Helper to reset 2 bits in a word. *)
-let reset_mask i =
- lnot (3 lsl ((i land 7) lsl 1))
-
-(* Initialize the lookup table from a list of segments, assigning
- a status to every character of each segment. The order of these
- assignments is relevant: it is possible to assign status [s] to
- a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is
- between [c1] and [c2]. *)
-let mk_lookup_table_from_unicode_tables_for status tables =
- List.iter
- (List.iter
- (fun (c1, c2) ->
- for i = c1 to c2 do
- table.(i lsr 3) <-
- (table.(i lsr 3) land (reset_mask i)) lor (mask i status)
- done))
- tables
-
-(* Look up into the table and interpret the found pattern. *)
-let lookup x =
- let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in
- if v = 1 then UnicodeLetter
- else if v = 2 then UnicodeIdentPart
- else if v = 3 then UnicodeSymbol
- else raise UnsupportedUtf8
-
-(* [classify_unicode] discriminates between 3 different kinds of
- symbols based on the standard unicode classification (extracted from
- Camomile). *)
-let classify_unicode =
- let single c = [ (c, c) ] in
- (* General tables. *)
- mk_lookup_table_from_unicode_tables_for UnicodeSymbol
- [
- Unicodetable.sm; (* Symbol, maths. *)
- Unicodetable.sc; (* Symbol, currency. *)
- Unicodetable.so; (* Symbol, modifier. *)
- Unicodetable.pd; (* Punctation, dash. *)
- Unicodetable.pc; (* Punctation, connector. *)
- Unicodetable.pe; (* Punctation, open. *)
- Unicodetable.ps; (* Punctation, close. *)
- Unicodetable.pi; (* Punctation, initial quote. *)
- Unicodetable.pf; (* Punctation, final quote. *)
- Unicodetable.po; (* Punctation, other. *)
- ];
- mk_lookup_table_from_unicode_tables_for UnicodeLetter
- [
- Unicodetable.lu; (* Letter, uppercase. *)
- Unicodetable.ll; (* Letter, lowercase. *)
- Unicodetable.lt; (* Letter, titlecase. *)
- Unicodetable.lo; (* Letter, others. *)
- ];
- mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
- [
- Unicodetable.nd; (* Number, decimal digits. *)
- Unicodetable.nl; (* Number, letter. *)
- Unicodetable.no; (* Number, other. *)
- ];
- (* Exceptions (from a previous version of this function). *)
- mk_lookup_table_from_unicode_tables_for UnicodeSymbol
- [
- single 0x000B2; (* Squared. *)
- single 0x0002E; (* Dot. *)
- ];
- mk_lookup_table_from_unicode_tables_for UnicodeLetter
- [
- single 0x005F; (* Underscore. *)
- single 0x00A0; (* Non breaking space. *)
- ];
- mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
- [
- single 0x0027; (* Special space. *)
- ];
- (* Lookup *)
- lookup
-
-exception End_of_input
-
-let utf8_of_unicode n =
- if n < 128 then
- String.make 1 (Char.chr n)
- else if n < 2048 then
- let s = String.make 2 (Char.chr (128 + n mod 64)) in
- begin
- s.[0] <- Char.chr (192 + n / 64);
- s
- end
- else if n < 65536 then
- let s = String.make 3 (Char.chr (128 + n mod 64)) in
- begin
- s.[1] <- Char.chr (128 + (n / 64) mod 64);
- s.[0] <- Char.chr (224 + n / 4096);
- s
- end
- else
- let s = String.make 4 (Char.chr (128 + n mod 64)) in
- begin
- s.[2] <- Char.chr (128 + (n / 64) mod 64);
- s.[1] <- Char.chr (128 + (n / 4096) mod 64);
- s.[0] <- Char.chr (240 + n / 262144);
- s
- end
-
-let next_utf8 s i =
- let err () = invalid_arg "utf8" in
- let l = String.length s - i in
- if l = 0 then raise End_of_input
- else let a = Char.code s.[i] in if a <= 0x7F then
- 1, a
- else if a land 0x40 = 0 or l = 1 then err ()
- else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err ()
- else if a land 0x20 = 0 then
- 2, (a land 0x1F) lsl 6 + (b land 0x3F)
- else if l = 2 then err ()
- else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err ()
- else if a land 0x10 = 0 then
- 3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F)
- else if l = 3 then err ()
- else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err ()
- else if a land 0x08 = 0 then
- 4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 +
- (c land 0x3F) lsl 6 + (d land 0x3F)
- else err ()
-
-(* Check the well-formedness of an identifier *)
+module Empty =
+struct
+ type t
+ let abort (x : t) = assert false
+end
-let check_initial handle j n s =
- match classify_unicode n with
- | UnicodeLetter -> ()
- | _ ->
- let c = String.sub s 0 j in
- handle ("Invalid character '"^c^"' at beginning of identifier \""^s^"\".")
+(* Strings *)
-let check_trailing handle i j n s =
- match classify_unicode n with
- | UnicodeLetter | UnicodeIdentPart -> ()
- | _ ->
- let c = String.sub s i j in
- handle ("Invalid character '"^c^"' in identifier \""^s^"\".")
+module String : CString.ExtS = CString
-let check_ident_gen handle s =
+let subst_command_placeholder s t =
+ let buff = Buffer.create (String.length s + String.length t) in
let i = ref 0 in
- if s <> ".." then try
- let j, n = next_utf8 s 0 in
- check_initial handle j n s;
- i := !i + j;
- try
- while true do
- let j, n = next_utf8 s !i in
- check_trailing handle !i j n s;
- i := !i + j
- done
- with End_of_input -> ()
- with
- | End_of_input -> error "The empty string is not an identifier."
- | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.")
- | Invalid_argument _ -> error (s^": invalid utf8 sequence.")
-
-let check_ident_soft = check_ident_gen warning
-let check_ident = check_ident_gen error
-
-let lowercase_unicode =
- let tree = Segmenttree.make Unicodetable.to_lower in
- fun unicode ->
- try
- match Segmenttree.lookup unicode tree with
- | `Abs c -> c
- | `Delta d -> unicode + d
- with Not_found -> unicode
-
-let lowercase_first_char_utf8 s =
- assert (s <> "");
- let j, n = next_utf8 s 0 in
- utf8_of_unicode (lowercase_unicode n)
-
-(** For extraction, we need to encode unicode character into ascii ones *)
-
-let ascii_of_ident s =
- let check_ascii s =
- let ok = ref true in
- String.iter (fun c -> if Char.code c >= 128 then ok := false) s;
- !ok
- in
- if check_ascii s then s else
- let i = ref 0 and out = ref "" in
- begin try while true do
- let j, n = next_utf8 s !i in
- out :=
- if n >= 128
- then Printf.sprintf "%s__U%04x_" !out n
- else Printf.sprintf "%s%c" !out s.[!i];
- i := !i + j
- done with End_of_input -> () end;
- !out
+ while (!i < String.length s) do
+ if s.[!i] = '%' && !i+1 < String.length s && s.[!i+1] = 's'
+ then (Buffer.add_string buff t;incr i)
+ else Buffer.add_char buff s.[!i];
+ incr i
+ done;
+ Buffer.contents buff
(* Lists *)
-let rec list_compare cmp l1 l2 =
- match l1,l2 with
- [], [] -> 0
- | _::_, [] -> 1
- | [], _::_ -> -1
- | x1::l1, x2::l2 ->
- (match cmp x1 x2 with
- | 0 -> list_compare cmp l1 l2
- | c -> c)
-
-let rec list_equal cmp l1 l2 =
- match l1, l2 with
- | [], [] -> true
- | x1 :: l1, x2 :: l2 ->
- cmp x1 x2 && list_equal cmp l1 l2
- | _ -> false
-
-let list_intersect l1 l2 =
- List.filter (fun x -> List.mem x l2) l1
-
-let list_union l1 l2 =
- let rec urec = function
- | [] -> l2
- | a::l -> if List.mem a l2 then urec l else a::urec l
- in
- urec l1
-
-let list_unionq l1 l2 =
- let rec urec = function
- | [] -> l2
- | a::l -> if List.memq a l2 then urec l else a::urec l
- in
- urec l1
-
-let list_subtract l1 l2 =
- if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1
-
-let list_subtractq l1 l2 =
- if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1
-
-let list_tabulate f len =
- let rec tabrec n =
- if n = len then [] else (f n)::(tabrec (n+1))
- in
- tabrec 0
-
-let list_addn n v =
- let rec aux n l =
- if n = 0 then l
- else aux (pred n) (v::l)
- in
- if n < 0 then invalid_arg "list_addn"
- else aux n
-
-let list_make n v = list_addn n v []
-
-let list_assign l n e =
- let rec assrec stk = function
- | ((h::t), 0) -> List.rev_append stk (e::t)
- | ((h::t), n) -> assrec (h::stk) (t, n-1)
- | ([], _) -> failwith "list_assign"
- in
- assrec [] (l,n)
-
-let rec list_smartmap f l = match l with
- [] -> l
- | h::tl ->
- let h' = f h and tl' = list_smartmap f tl in
- if h'==h && tl'==tl then l
- else h'::tl'
-
-let list_map_left f = (* ensures the order in case of side-effects *)
- let rec map_rec = function
- | [] -> []
- | x::l -> let v = f x in v :: map_rec l
- in
- map_rec
-
-let list_map_i f =
- let rec map_i_rec i = function
- | [] -> []
- | x::l -> let v = f i x in v :: map_i_rec (i+1) l
- in
- map_i_rec
-
-let list_map2_i f i l1 l2 =
- let rec map_i i = function
- | ([], []) -> []
- | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
- | (_, _) -> invalid_arg "map2_i"
- in
- map_i i (l1,l2)
-
-let list_map3 f l1 l2 l3 =
- let rec map = function
- | ([], [], []) -> []
- | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
- | (_, _, _) -> invalid_arg "map3"
- in
- map (l1,l2,l3)
-
-let list_map4 f l1 l2 l3 l4 =
- let rec map = function
- | ([], [], [], []) -> []
- | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4)
- | (_, _, _, _) -> invalid_arg "map4"
- in
- map (l1,l2,l3,l4)
-
-let list_map_to_array f l =
- Array.of_list (List.map f l)
-
-let rec list_smartfilter f l = match l with
- [] -> l
- | h::tl ->
- let tl' = list_smartfilter f tl in
- if f h then
- if tl' == tl then l
- else h :: tl'
- else tl'
-
-let list_index_f f x =
- let rec index_x n = function
- | y::l -> if f x y then n else index_x (succ n) l
- | [] -> raise Not_found
- in
- index_x 1
-
-let list_index0_f f x l = list_index_f f x l - 1
-
-let list_index x =
- let rec index_x n = function
- | y::l -> if x = y then n else index_x (succ n) l
- | [] -> raise Not_found
- in
- index_x 1
-
-let list_index0 x l = list_index x l - 1
-
-let list_unique_index x =
- let rec index_x n = function
- | y::l ->
- if x = y then
- if List.mem x l then raise Not_found
- else n
- else index_x (succ n) l
- | [] -> raise Not_found
- in index_x 1
-
-let list_fold_right_i f i l =
- let rec it_list_f i l a = match l with
- | [] -> a
- | b::l -> f (i-1) b (it_list_f (i-1) l a)
- in
- it_list_f (List.length l + i) l
-
-let list_fold_left_i f =
- let rec it_list_f i a = function
- | [] -> a
- | b::l -> it_list_f (i+1) (f i a b) l
- in
- it_list_f
-
-let rec list_fold_left3 f accu l1 l2 l3 =
- match (l1, l2, l3) with
- ([], [], []) -> accu
- | (a1::l1, a2::l2, a3::l3) -> list_fold_left3 f (f accu a1 a2 a3) l1 l2 l3
- | (_, _, _) -> invalid_arg "list_fold_left3"
-
-(* [list_fold_right_and_left f [a1;...;an] hd =
- f (f (... (f (f hd
- an
- [an-1;...;a1])
- an-1
- [an-2;...;a1])
- ...)
- a2
- [a1])
- a1
- []] *)
-
-let rec list_fold_right_and_left f l hd =
- let rec aux tl = function
- | [] -> hd
- | a::l -> let hd = aux (a::tl) l in f hd a tl
- in aux [] l
-
-let list_iter3 f l1 l2 l3 =
- let rec iter = function
- | ([], [], []) -> ()
- | ((h1::t1), (h2::t2), (h3::t3)) -> f h1 h2 h3; iter (t1,t2,t3)
- | (_, _, _) -> invalid_arg "map3"
- in
- iter (l1,l2,l3)
-
-let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l
-
-let list_for_all_i p =
- let rec for_all_p i = function
- | [] -> true
- | a::l -> p i a && for_all_p (i+1) l
- in
- for_all_p
-
-let list_except x l = List.filter (fun y -> not (x = y)) l
-
-let list_remove = list_except (* Alias *)
-
-let rec list_remove_first a = function
- | b::l when a = b -> l
- | b::l -> b::list_remove_first a l
- | [] -> raise Not_found
-
-let rec list_remove_assoc_in_triple x = function
- | [] -> []
- | (y,_,_ as z)::l -> if x = y then l else z::list_remove_assoc_in_triple x l
-
-let rec list_assoc_snd_in_triple x = function
- [] -> raise Not_found
- | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_snd_in_triple x l
-
-let list_add_set x l = if List.mem x l then l else x::l
-
-let list_eq_set l1 l2 =
- let rec aux l1 = function
- | [] -> l1 = []
- | a::l2 -> aux (list_remove_first a l1) l2 in
- try aux l1 l2 with Not_found -> false
-
-let list_for_all2eq f l1 l2 =
- try List.for_all2 f l1 l2 with Invalid_argument _ -> false
-
-let list_filter_i p =
- let rec filter_i_rec i = function
- | [] -> []
- | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
- in
- filter_i_rec 0
-
-let rec list_sep_last = function
- | [] -> failwith "sep_last"
- | hd::[] -> (hd,[])
- | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl)
-
-let list_try_find_i f =
- let rec try_find_f n = function
- | [] -> failwith "try_find_i"
- | h::t -> try f n h with Failure _ -> try_find_f (n+1) t
- in
- try_find_f
-
-let list_try_find f =
- let rec try_find_f = function
- | [] -> failwith "try_find"
- | h::t -> try f h with Failure _ -> try_find_f t
- in
- try_find_f
-
-let list_uniquize l =
- let visited = Hashtbl.create 23 in
- let rec aux acc = function
- | h::t -> if Hashtbl.mem visited h then aux acc t else
- begin
- Hashtbl.add visited h h;
- aux (h::acc) t
- end
- | [] -> List.rev acc
- in aux [] l
-
-let rec list_distinct l =
- let visited = Hashtbl.create 23 in
- let rec loop = function
- | h::t ->
- if Hashtbl.mem visited h then false
- else
- begin
- Hashtbl.add visited h h;
- loop t
- end
- | [] -> true
- in loop l
-
-let rec list_merge_uniq cmp l1 l2 =
- match l1, l2 with
- | [], l2 -> l2
- | l1, [] -> l1
- | h1 :: t1, h2 :: t2 ->
- let c = cmp h1 h2 in
- if c = 0
- then h1 :: list_merge_uniq cmp t1 t2
- else if c <= 0
- then h1 :: list_merge_uniq cmp t1 l2
- else h2 :: list_merge_uniq cmp l1 t2
-
-let rec list_duplicates = function
- | [] -> []
- | x::l ->
- let l' = list_duplicates l in
- if List.mem x l then list_add_set x l' else l'
-
-let rec list_filter2 f = function
- | [], [] as p -> p
- | d::dp, l::lp ->
- let (dp',lp' as p) = list_filter2 f (dp,lp) in
- if f d l then d::dp', l::lp' else p
- | _ -> invalid_arg "list_filter2"
-
-let rec list_map_filter f = function
- | [] -> []
- | x::l ->
- let l' = list_map_filter f l in
- match f x with None -> l' | Some y -> y::l'
-
-let list_map_filter_i f =
- let rec aux i = function
- | [] -> []
- | x::l ->
- let l' = aux (succ i) l in
- match f i x with None -> l' | Some y -> y::l'
- in aux 0
-
-let list_filter_along f filter l =
- snd (list_filter2 (fun b c -> f b) (filter,l))
-
-let list_filter_with filter l =
- list_filter_along (fun x -> x) filter l
-
-let list_subset l1 l2 =
- let t2 = Hashtbl.create 151 in
- List.iter (fun x -> Hashtbl.add t2 x ()) l2;
- let rec look = function
- | [] -> true
- | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
- in
- look l1
-
-(* [list_chop i l] splits [l] into two lists [(l1,l2)] such that
- [l1++l2=l] and [l1] has length [i].
- It raises [Failure] when [i] is negative or greater than the length of [l] *)
-
-let list_chop n l =
- let rec chop_aux i acc = function
- | tl when i=0 -> (List.rev acc, tl)
- | h::t -> chop_aux (pred i) (h::acc) t
- | [] -> failwith "list_chop"
- in
- chop_aux n [] l
-
-(* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that
- [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
- If there is no such [a], then it returns [(l,[])] instead *)
-let list_split_when p =
- let rec split_when_loop x y =
- match y with
- | [] -> (List.rev x,[])
- | (a::l) -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l
- in
- split_when_loop []
-
-(* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of
- [l1] satisfy [p] and elements of [l2] do not; order is preserved *)
-let list_split_by p =
- let rec split_by_loop = function
- | [] -> ([],[])
- | a::l ->
- let (l1,l2) = split_by_loop l in if p a then (a::l1,l2) else (l1,a::l2)
- in
- split_by_loop
-
-let rec list_split3 = function
- | [] -> ([], [], [])
- | (x,y,z)::l ->
- let (rx, ry, rz) = list_split3 l in (x::rx, y::ry, z::rz)
-
-let rec list_insert_in_class f a = function
- | [] -> [[a]]
- | (b::_ as l)::classes when f a b -> (a::l)::classes
- | l::classes -> l :: list_insert_in_class f a classes
-
-let list_partition_by f l =
- List.fold_right (list_insert_in_class f) l []
-
-let list_firstn n l =
- let rec aux acc = function
- | (0, l) -> List.rev acc
- | (n, (h::t)) -> aux (h::acc) (pred n, t)
- | _ -> failwith "firstn"
- in
- aux [] (n,l)
-
-let rec list_last = function
- | [] -> failwith "list_last"
- | [x] -> x
- | _ :: l -> list_last l
-
-let list_lastn n l =
- let len = List.length l in
- let rec aux m l =
- if m = n then l else aux (m - 1) (List.tl l)
- in
- if len < n then failwith "lastn" else aux len l
-
-let rec list_skipn n l = match n,l with
- | 0, _ -> l
- | _, [] -> failwith "list_skipn"
- | n, _::l -> list_skipn (pred n) l
-
-let rec list_skipn_at_least n l =
- try list_skipn n l with Failure _ -> []
-
-let list_prefix_of prefl l =
- let rec prefrec = function
- | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2)
- | ([], _) -> true
- | (_, _) -> false
- in
- prefrec (prefl,l)
-
-let list_drop_prefix p l =
-(* if l=p++t then return t else l *)
- let rec list_drop_prefix_rec = function
- | ([], tl) -> Some tl
- | (_, []) -> None
- | (h1::tp, h2::tl) ->
- if h1 = h2 then list_drop_prefix_rec (tp,tl) else None
- in
- match list_drop_prefix_rec (p,l) with
- | Some r -> r
- | None -> l
-
-let list_map_append f l = List.flatten (List.map f l)
-let list_join_map = list_map_append (* Alias *)
-
-let list_map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2)
-
-let list_share_tails l1 l2 =
- let rec shr_rev acc = function
- | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
- | (l1,l2) -> (List.rev l1, List.rev l2, acc)
- in
- shr_rev [] (List.rev l1, List.rev l2)
-
-let rec list_fold_map f e = function
- | [] -> (e,[])
- | h::t ->
- let e',h' = f e h in
- let e'',t' = list_fold_map f e' t in
- e'',h'::t'
-
-(* (* tail-recursive version of the above function *)
-let list_fold_map f e l =
- let g (e,b') h =
- let (e',h') = f e h in
- (e',h'::b')
- in
- let (e',lrev) = List.fold_left g (e,[]) l in
- (e',List.rev lrev)
-*)
-
-(* The same, based on fold_right, with the effect accumulated on the right *)
-let list_fold_map' f l e =
- List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e)
-
-let list_map_assoc f = List.map (fun (x,a) -> (x,f a))
-
-let rec list_assoc_f f a = function
- | (x, e) :: xs -> if f a x then e else list_assoc_f f a xs
- | [] -> raise Not_found
-
-(* Specification:
- - =p= is set equality (double inclusion)
- - f such that \forall l acc, (f l acc) =p= append (f l []) acc
- - let g = fun x -> f x [] in
- - union_map f l acc =p= append (flatten (map g l)) acc
- *)
-let list_union_map f l acc =
- List.fold_left
- (fun x y -> f y x)
- acc
- l
-
-(* A generic cartesian product: for any operator (**),
- [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
- and so on if there are more elements in the lists. *)
-
-let rec list_cartesian op l1 l2 =
- list_map_append (fun x -> List.map (op x) l2) l1
-
-(* [list_cartesians] is an n-ary cartesian product: it iterates
- [list_cartesian] over a list of lists. *)
-
-let list_cartesians op init ll =
- List.fold_right (list_cartesian op) ll [init]
-
-(* list_combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *)
-
-let list_combinations l = list_cartesians (fun x l -> x::l) [] l
-
-let rec list_combine3 x y z =
- match x, y, z with
- | [], [], [] -> []
- | (x :: xs), (y :: ys), (z :: zs) ->
- (x, y, z) :: list_combine3 xs ys zs
- | _, _, _ -> raise (Invalid_argument "list_combine3")
-
-(* Keep only those products that do not return None *)
-
-let rec list_cartesian_filter op l1 l2 =
- list_map_append (fun x -> list_map_filter (op x) l2) l1
+module List : CList.ExtS = CList
-(* Keep only those products that do not return None *)
-
-let rec list_cartesians_filter op init ll =
- List.fold_right (list_cartesian_filter op) ll [init]
-
-(* Drop the last element of a list *)
-
-let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: list_drop_last tl
-
-(* Factorize lists of pairs according to the left argument *)
-let rec list_factorize_left = function
- | (a,b)::l ->
- let al,l' = list_split_by (fun (a',b) -> a=a') l in
- (a,(b::List.map snd al)) :: list_factorize_left l'
- | [] ->
- []
+let (@) = CList.append
(* Arrays *)
-let array_compare item_cmp v1 v2 =
- let c = compare (Array.length v1) (Array.length v2) in
- if c<>0 then c else
- let rec cmp = function
- -1 -> 0
- | i ->
- let c' = item_cmp v1.(i) v2.(i) in
- if c'<>0 then c'
- else cmp (i-1) in
- cmp (Array.length v1 - 1)
-
-let array_equal cmp t1 t2 =
- Array.length t1 = Array.length t2 &&
- let rec aux i =
- (i = Array.length t1) || (cmp t1.(i) t2.(i) && aux (i + 1))
- in aux 0
-
-let array_exists f v =
- let rec exrec = function
- | -1 -> false
- | n -> (f v.(n)) || (exrec (n-1))
- in
- exrec ((Array.length v)-1)
-
-let array_for_all f v =
- let rec allrec = function
- | -1 -> true
- | n -> (f v.(n)) && (allrec (n-1))
- in
- allrec ((Array.length v)-1)
-
-let array_for_all2 f v1 v2 =
- let rec allrec = function
- | -1 -> true
- | n -> (f v1.(n) v2.(n)) && (allrec (n-1))
- in
- let lv1 = Array.length v1 in
- lv1 = Array.length v2 && allrec (pred lv1)
-
-let array_for_all3 f v1 v2 v3 =
- let rec allrec = function
- | -1 -> true
- | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1))
- in
- let lv1 = Array.length v1 in
- lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1)
-
-let array_for_all4 f v1 v2 v3 v4 =
- let rec allrec = function
- | -1 -> true
- | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1))
- in
- let lv1 = Array.length v1 in
- lv1 = Array.length v2 &&
- lv1 = Array.length v3 &&
- lv1 = Array.length v4 &&
- allrec (pred lv1)
-
-let array_for_all_i f i v =
- let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in
- allrec i 0
-
-exception Found of int
-
-let array_find_i (pred: int -> 'a -> bool) (arr: 'a array) : int option =
- try
- for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
- None
- with Found i -> Some i
-
-let array_hd v =
- match Array.length v with
- | 0 -> failwith "array_hd"
- | _ -> v.(0)
+module Array : CArray.ExtS = CArray
-let array_tl v =
- match Array.length v with
- | 0 -> failwith "array_tl"
- | n -> Array.sub v 1 (pred n)
+(* Sets *)
-let array_last v =
- match Array.length v with
- | 0 -> failwith "array_last"
- | n -> v.(pred n)
+module Set = CSet
-let array_cons e v = Array.append [|e|] v
+(* Maps *)
-let array_rev t =
- let n=Array.length t in
- if n <=0 then ()
- else
- let tmp=ref t.(0) in
- for i=0 to pred (n/2) do
- tmp:=t.((pred n)-i);
- t.((pred n)-i)<- t.(i);
- t.(i)<- !tmp
- done
+module Map = CMap
-let array_fold_right_i f v a =
- let rec fold a n =
- if n=0 then a
- else
- let k = n-1 in
- fold (f k v.(k) a) k in
- fold a (Array.length v)
+(* Stacks *)
-let array_fold_left_i f v a =
- let n = Array.length a in
- let rec fold i v = if i = n then v else fold (succ i) (f i v a.(i)) in
- fold 0 v
-
-let array_fold_right2 f v1 v2 a =
- let lv1 = Array.length v1 in
- let rec fold a n =
- if n=0 then a
- else
- let k = n-1 in
- fold (f v1.(k) v2.(k) a) k in
- if Array.length v2 <> lv1 then invalid_arg "array_fold_right2";
- fold a lv1
-
-let array_fold_left2 f a v1 v2 =
- let lv1 = Array.length v1 in
- let rec fold a n =
- if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n)
- in
- if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
- fold a 0
-
-let array_fold_left2_i f a v1 v2 =
- let lv1 = Array.length v1 in
- let rec fold a n =
- if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n)
- in
- if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
- fold a 0
-
-let array_fold_left3 f a v1 v2 v3 =
- let lv1 = Array.length v1 in
- let rec fold a n =
- if n >= lv1 then a else fold (f a v1.(n) v2.(n) v3.(n)) (succ n)
- in
- if Array.length v2 <> lv1 || Array.length v3 <> lv1 then
- invalid_arg "array_fold_left2";
- fold a 0
-
-let array_fold_left_from n f a v =
- let rec fold a n =
- if n >= Array.length v then a else fold (f a v.(n)) (succ n)
- in
- fold a n
-
-let array_fold_right_from n f v a =
- let rec fold n =
- if n >= Array.length v then a else f v.(n) (fold (succ n))
- in
- fold n
-
-let array_app_tl v l =
- if Array.length v = 0 then invalid_arg "array_app_tl";
- array_fold_right_from 1 (fun e l -> e::l) v l
-
-let array_list_of_tl v =
- if Array.length v = 0 then invalid_arg "array_list_of_tl";
- array_fold_right_from 1 (fun e l -> e::l) v []
-
-let array_map_to_list f v =
- List.map f (Array.to_list v)
-
-let array_chop n v =
- let vlen = Array.length v in
- if n > vlen then failwith "array_chop";
- (Array.sub v 0 n, Array.sub v n (vlen-n))
-
-exception Local of int
-
-(* If none of the elements is changed by f we return ar itself.
- The for loop looks for the first such an element.
- If found it is temporarily stored in a ref and the new array is produced,
- but f is not re-applied to elements that are already checked *)
-let array_smartmap f ar =
- let ar_size = Array.length ar in
- let aux = ref None in
- try
- for i = 0 to ar_size-1 do
- let a = ar.(i) in
- let a' = f a in
- if a != a' then (* pointer (in)equality *) begin
- aux := Some a';
- raise (Local i)
- end
- done;
- ar
- with
- Local i ->
- let copy j =
- if j<i then ar.(j)
- else if j=i then
- match !aux with Some a' -> a' | None -> failwith "Error"
- else f (ar.(j))
- in
- Array.init ar_size copy
-
-let array_map2 f v1 v2 =
- if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
- if Array.length v1 == 0 then
- [| |]
- else begin
- let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in
- for i = 1 to pred (Array.length v1) do
- res.(i) <- f v1.(i) v2.(i)
- done;
- res
- end
-
-let array_map2_i f v1 v2 =
- if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
- if Array.length v1 == 0 then
- [| |]
- else begin
- let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in
- for i = 1 to pred (Array.length v1) do
- res.(i) <- f i v1.(i) v2.(i)
- done;
- res
- end
-
-let array_map3 f v1 v2 v3 =
- if Array.length v1 <> Array.length v2 ||
- Array.length v1 <> Array.length v3 then invalid_arg "array_map3";
- if Array.length v1 == 0 then
- [| |]
- else begin
- let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in
- for i = 1 to pred (Array.length v1) do
- res.(i) <- f v1.(i) v2.(i) v3.(i)
- done;
- res
- end
-
-let array_map_left f a = (* Ocaml does not guarantee Array.map is LR *)
- let l = Array.length a in (* (even if so), then we rewrite it *)
- if l = 0 then [||] else begin
- let r = Array.create l (f a.(0)) in
- for i = 1 to l - 1 do
- r.(i) <- f a.(i)
- done;
- r
- end
-
-let array_map_left_pair f a g b =
- let l = Array.length a in
- if l = 0 then [||],[||] else begin
- let r = Array.create l (f a.(0)) in
- let s = Array.create l (g b.(0)) in
- for i = 1 to l - 1 do
- r.(i) <- f a.(i);
- s.(i) <- g b.(i)
- done;
- r, s
- end
-
-let array_iter2 f v1 v2 =
- let n = Array.length v1 in
- if Array.length v2 <> n then invalid_arg "array_iter2"
- else for i = 0 to n - 1 do f v1.(i) v2.(i) done
-
-let pure_functional = false
-
-let array_fold_map' f v e =
-if pure_functional then
- let (l,e) =
- Array.fold_right
- (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
- v ([],e) in
- (Array.of_list l,e)
-else
- let e' = ref e in
- let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in
- (v',!e')
-
-let array_fold_map f e v =
- let e' = ref e in
- let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in
- (!e',v')
-
-let array_fold_map2' f v1 v2 e =
- let e' = ref e in
- let v' =
- array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2
- in
- (v',!e')
-
-let array_distinct v =
- let visited = Hashtbl.create 23 in
- try
- Array.iter
- (fun x ->
- if Hashtbl.mem visited x then raise Exit
- else Hashtbl.add visited x x)
- v;
- true
- with Exit -> false
-
-let array_union_map f a acc =
- Array.fold_left
- (fun x y -> f y x)
- acc
- a
-
-let array_rev_to_list a =
- let rec tolist i res =
- if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in
- tolist 0 []
-
-let array_filter_along f filter v =
- Array.of_list (list_filter_along f filter (Array.to_list v))
-
-let array_filter_with filter v =
- Array.of_list (list_filter_with filter (Array.to_list v))
-
-(* Stream *)
-
-let stream_nth n st =
- try List.nth (Stream.npeek (n+1) st) n
- with Failure _ -> raise Stream.Failure
-
-let stream_njunk n st =
- for i = 1 to n do Stream.junk st done
+module Stack = CStack
(* Matrices *)
let matrix_transpose mat =
List.fold_right (List.map2 (fun p c -> p::c)) mat
- (if mat = [] then [] else List.map (fun _ -> []) (List.hd mat))
+ (if List.is_empty mat then [] else List.map (fun _ -> []) (List.hd mat))
(* Functions *)
@@ -1263,18 +91,28 @@ let compose f g x = f (g x)
let const x _ = x
-let iterate f =
- let rec iterate_f n x =
- if n <= 0 then x else iterate_f (pred n) (f x)
+let iterate =
+ let rec iterate_f f n x =
+ if n <= 0 then x else iterate_f f (pred n) (f x)
in
iterate_f
let repeat n f x =
- for i = 1 to n do f x done
+ let rec loop i = if i <> 0 then (f x; loop (i - 1)) in loop n
+
+let app_opt f x =
+ match f with
+ | Some f -> f x
+ | None -> x
-let iterate_for a b f x =
- let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in
- iterate a x
+(* Stream *)
+
+let stream_nth n st =
+ try List.nth (Stream.npeek (n+1) st) n
+ with Failure _ -> raise Stream.Failure
+
+let stream_njunk n st =
+ repeat n Stream.junk st
(* Delayed computations *)
@@ -1284,245 +122,13 @@ let delayed_force f = f ()
(* Misc *)
-type ('a,'b) union = Inl of 'a | Inr of 'b
-
-module Intset = Set.Make(struct type t = int let compare = compare end)
-
-module Intmap = Map.Make(struct type t = int let compare = compare end)
-
-let intmap_in_dom x m =
- try let _ = Intmap.find x m in true with Not_found -> false
-
-let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m []
-
-let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m []
-
-let interval n m =
- let rec interval_n (l,m) =
- if n > m then l else interval_n (m::l,pred m)
- in
- interval_n ([],m)
-
-
-let map_succeed f =
- let rec map_f = function
- | [] -> []
- | h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t
- in
- map_f
-
-(* Pretty-printing *)
-
-let pr_spc = spc
-let pr_fnl = fnl
-let pr_int = int
-let pr_str = str
-let pr_comma () = str "," ++ spc ()
-let pr_semicolon () = str ";" ++ spc ()
-let pr_bar () = str "|" ++ spc ()
-let pr_arg pr x = spc () ++ pr x
-let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x
-let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x
-
-let nth n = str (ordinal n)
-
-(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
-
-let rec prlist elem l = match l with
- | [] -> mt ()
- | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t)
-
-(* unlike all other functions below, [prlist] works lazily.
- if a strict behavior is needed, use [prlist_strict] instead.
- evaluation is done from left to right. *)
-
-let rec prlist_strict elem l = match l with
- | [] -> mt ()
- | h::t ->
- let e = elem h in let r = prlist_strict elem t in e++r
-
-(* [prlist_with_sep sep pr [a ; ... ; c]] outputs
- [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
-
-let rec prlist_with_sep sep elem l = match l with
- | [] -> mt ()
- | [h] -> elem h
- | h::t ->
- let e = elem h and s = sep() and r = prlist_with_sep sep elem t in
- e ++ s ++ r
-
-(* Print sequence of objects separated by space (unless an element is empty) *)
-
-let rec pr_sequence elem = function
- | [] -> mt ()
- | [h] -> elem h
- | h::t ->
- let e = elem h and r = pr_sequence elem t in
- if e = mt () then r else e ++ spc () ++ r
-
-(* [pr_enum pr [a ; b ; ... ; c]] outputs
- [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *)
-
-let pr_enum pr l =
- let c,l' = list_sep_last l in
- prlist_with_sep pr_comma pr l' ++
- (if l'<>[] then str " and" ++ spc () else mt()) ++ pr c
-
-let pr_vertical_list pr = function
- | [] -> str "none" ++ fnl ()
- | l -> fnl () ++ str " " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl ()
-
-(* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs
- [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *)
-
-let prvecti_with_sep sep elem v =
- let rec pr i =
- if i = 0 then
- elem 0 v.(0)
- else
- let r = pr (i-1) and s = sep () and e = elem i v.(i) in
- r ++ s ++ e
- in
- let n = Array.length v in
- if n = 0 then mt () else pr (n - 1)
-
-(* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *)
-
-let prvecti elem v = prvecti_with_sep mt elem v
-
-(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs
- [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
-
-let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v
-
-(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *)
-
-let prvect elem v = prvect_with_sep mt elem v
-
-let pr_located pr (loc,x) =
- if Flags.do_beautify() && loc<>dummy_loc then
- let (b,e) = unloc loc in
- comment b ++ pr x ++ comment e
- else pr x
-
-let surround p = hov 1 (str"(" ++ p ++ str")")
-
-(*s Memoization *)
-
-let memo1_eq eq f =
- let m = ref None in
- fun x ->
- match !m with
- Some(x',y') when eq x x' -> y'
- | _ -> let y = f x in m := Some(x,y); y
-
-let memo1_1 f = memo1_eq (==) f
-let memo1_2 f =
- let f' =
- memo1_eq (fun (x,y) (x',y') -> x==x' && y==y') (fun (x,y) -> f x y) in
- (fun x y -> f'(x,y))
-
-(* Memorizes the last n distinct calls to f. Since there is no hash,
- Efficient only for small n. *)
-let memon_eq eq n f =
- let cache = ref [] in (* the cache: a stack *)
- let m = ref 0 in (* usage of the cache *)
- let rec find x = function
- | (x',y')::l when eq x x' -> y', l (* cell is moved to the top *)
- | [] -> (* we assume n>0, so creating one memo cell is OK *)
- incr m; (f x, [])
- | [_] when !m>=n -> f x,[] (* cache is full: dispose of last cell *)
- | p::l (* not(eq x (fst p)) *) -> let (y,l') = find x l in (y, p::l')
- in
- (fun x ->
- let (y,l) = find x !cache in
- cache := (x,y)::l;
- y)
-
-
-(*s Size of ocaml values. *)
-
-module Size = struct
-
- (*s Pointers already visited are stored in a hash-table, where
- comparisons are done using physical equality. *)
-
- module H = Hashtbl.Make(
- struct
- type t = Obj.t
- let equal = (==)
- let hash o = Hashtbl.hash (Obj.magic o : int)
- end)
-
- let node_table = (H.create 257 : unit H.t)
-
- let in_table o = try H.find node_table o; true with Not_found -> false
-
- let add_in_table o = H.add node_table o ()
-
- let reset_table () = H.clear node_table
-
- (*s Objects are traversed recursively, as soon as their tags are less than
- [no_scan_tag]. [count] records the numbers of words already visited. *)
-
- let size_of_double = Obj.size (Obj.repr 1.0)
-
- let count = ref 0
-
- let rec traverse t =
- if not (in_table t) then begin
- add_in_table t;
- if Obj.is_block t then begin
- let n = Obj.size t in
- let tag = Obj.tag t in
- if tag < Obj.no_scan_tag then begin
- count := !count + 1 + n;
- for i = 0 to n - 1 do
- let f = Obj.field t i in
- if Obj.is_block f then traverse f
- done
- end else if tag = Obj.string_tag then
- count := !count + 1 + n
- else if tag = Obj.double_tag then
- count := !count + size_of_double
- else if tag = Obj.double_array_tag then
- count := !count + 1 + size_of_double * n
- else
- incr count
- end
- end
-
- (*s Sizes of objects in words and in bytes. The size in bytes is computed
- system-independently according to [Sys.word_size]. *)
-
- let size_w o =
- reset_table ();
- count := 0;
- traverse (Obj.repr o);
- !count
-
- let size_b o = (size_w o) * (Sys.word_size / 8)
-
- let size_kb o = (size_w o) / (8192 / Sys.word_size)
-
-end
-
-let size_w = Size.size_w
-let size_b = Size.size_b
-let size_kb = Size.size_kb
-
-(*s Total size of the allocated ocaml heap. *)
-
-let heap_size () =
- let stat = Gc.stat ()
- and control = Gc.get () in
- let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in
- (max_words_total * (Sys.word_size / 8))
+type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b
+type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a
-let heap_size_kb () = (heap_size () + 1023) / 1024
+let map_union f g = function
+ | Inl a -> Inl (f a)
+ | Inr b -> Inr (g b)
-(*s interruption *)
+type iexn = Exninfo.iexn
-let interrupt = ref false
-let check_for_interrupt () =
- if !interrupt then begin interrupt := false; raise Sys.Break end
+let iraise = Exninfo.iraise
diff --git a/lib/util.mli b/lib/util.mli
index 530e838a..4fce809c 100644
--- a/lib/util.mli
+++ b/lib/util.mli
@@ -1,73 +1,20 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Pp
-open Compat
-
(** This module contains numerous utility functions on strings, lists,
arrays, etc. *)
-(** {6 ... } *)
-(** Errors. [Anomaly] is used for system errors and [UserError] for the
- user's ones. *)
-
-exception Anomaly of string * std_ppcmds
-val anomaly : string -> 'a
-val anomalylabstrm : string -> std_ppcmds -> 'a
-
-exception UserError of string * std_ppcmds
-val error : string -> 'a
-val errorlabstrm : string -> std_ppcmds -> 'a
-
-exception AlreadyDeclared of std_ppcmds
-val alreadydeclared : std_ppcmds -> 'a
-
-(** [todo] is for running of an incomplete code its implementation is
- "do nothing" (or print a message), but this function should not be
- used in a released code *)
-
-val todo : string -> unit
-
-exception Timeout
-
-type loc = Loc.t
-
-type 'a located = loc * 'a
-
-val unloc : loc -> int * int
-val make_loc : int * int -> loc
-val dummy_loc : loc
-val join_loc : loc -> loc -> loc
-
-val anomaly_loc : loc * string * std_ppcmds -> 'a
-val user_err_loc : loc * string * std_ppcmds -> 'a
-val invalid_arg_loc : loc * string -> 'a
-val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
-val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
-val down_located : ('a -> 'b) -> 'a located -> 'b
-
-(** Like [Exc_located], but specifies the outermost file read, the
- input buffer associated to the location of the error (or the module name
- if boolean is true), and the error itself. *)
-
-exception Error_in_file of string * (bool * string * loc) * exn
-
(** Mapping under pairs *)
val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b
-(** Going down pairs *)
-
-val down_fst : ('a -> 'b) -> 'a * 'c -> 'b
-val down_snd : ('a -> 'b) -> 'c * 'a -> 'b
-
(** Mapping under triple *)
val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd
@@ -87,216 +34,42 @@ val is_digit : char -> bool
val is_ident_tail : char -> bool
val is_blank : char -> bool
+(** {6 Empty type} *)
+
+module Empty :
+sig
+ type t
+ val abort : t -> 'a
+end
+
(** {6 Strings. } *)
-val explode : string -> string list
-val implode : string list -> string
-val strip : string -> string
-val drop_simple_quotes : string -> string
-val string_index_from : string -> int -> string -> int
-val string_string_contains : where:string -> what:string -> bool
-val plural : int -> string -> string
-val ordinal : int -> string
-val split_string_at : char -> string -> string list
+module String : CString.ExtS
-val parse_loadpath : string -> string list
+(** Substitute %s in the first chain by the second chain *)
+val subst_command_placeholder : string -> string -> string
-module Stringset : Set.S with type elt = string
-module Stringmap : Map.S with type key = string
+(** {6 Lists. } *)
-type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol
+module List : CList.ExtS
-exception UnsupportedUtf8
+val (@) : 'a list -> 'a list -> 'a list
-val classify_unicode : int -> utf8_status
-val check_ident : string -> unit
-val check_ident_soft : string -> unit
-val lowercase_first_char_utf8 : string -> string
-val ascii_of_ident : string -> string
+(** {6 Arrays. } *)
-(** {6 Lists. } *)
+module Array : CArray.ExtS
-val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
-val list_equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
-val list_add_set : 'a -> 'a list -> 'a list
-val list_eq_set : 'a list -> 'a list -> bool
-val list_intersect : 'a list -> 'a list -> 'a list
-val list_union : 'a list -> 'a list -> 'a list
-val list_unionq : 'a list -> 'a list -> 'a list
-val list_subtract : 'a list -> 'a list -> 'a list
-val list_subtractq : 'a list -> 'a list -> 'a list
-
-(** [list_tabulate f n] builds [[f 0; ...; f (n-1)]] *)
-val list_tabulate : (int -> 'a) -> int -> 'a list
-val list_make : int -> 'a -> 'a list
-val list_assign : 'a list -> int -> 'a -> 'a list
-val list_distinct : 'a list -> bool
-val list_duplicates : 'a list -> 'a list
-val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list
-val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list
-val list_map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
-val list_filter_with : bool list -> 'a list -> 'a list
-val list_filter_along : ('a -> bool) -> 'a list -> 'b list -> 'b list
-
-(** [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i
- [ f ai == ai], then [list_smartmap f l==l] *)
-val list_smartmap : ('a -> 'a) -> 'a list -> 'a list
-val list_map_left : ('a -> 'b) -> 'a list -> 'b list
-val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
-val list_map2_i :
- (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
-val list_map3 :
- ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
-val list_map4 :
- ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
-val list_map_to_array : ('a -> 'b) -> 'a list -> 'b array
-val list_filter_i :
- (int -> 'a -> bool) -> 'a list -> 'a list
-
-(** [list_smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i
- [f ai = true], then [list_smartfilter f l==l] *)
-val list_smartfilter : ('a -> bool) -> 'a list -> 'a list
-
-(** [list_index] returns the 1st index of an element in a list (counting from 1) *)
-val list_index : 'a -> 'a list -> int
-val list_index_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int
-
-(** [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *)
-val list_unique_index : 'a -> 'a list -> int
-
-(** [list_index0] behaves as [list_index] except that it starts counting at 0 *)
-val list_index0 : 'a -> 'a list -> int
-val list_index0_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int
-val list_iter3 : ('a -> 'b -> 'c -> unit) -> 'a list -> 'b list -> 'c list -> unit
-val list_iter_i : (int -> 'a -> unit) -> 'a list -> unit
-val list_fold_right_i : (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
-val list_fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
-val list_fold_right_and_left :
- ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
-val list_fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
-val list_for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
-val list_except : 'a -> 'a list -> 'a list
-val list_remove : 'a -> 'a list -> 'a list
-val list_remove_first : 'a -> 'a list -> 'a list
-val list_remove_assoc_in_triple : 'a -> ('a * 'b * 'c) list -> ('a * 'b * 'c) list
-val list_assoc_snd_in_triple : 'a -> ('a * 'b * 'c) list -> 'b
-val list_for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
-val list_sep_last : 'a list -> 'a * 'a list
-val list_try_find_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b
-val list_try_find : ('a -> 'b) -> 'a list -> 'b
-val list_uniquize : 'a list -> 'a list
-
-(** merges two sorted lists and preserves the uniqueness property: *)
-val list_merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
-val list_subset : 'a list -> 'a list -> bool
-val list_chop : int -> 'a list -> 'a list * 'a list
-(* former [list_split_at] was a duplicate of [list_chop] *)
-val list_split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
-val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list
-val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
-val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list
-val list_firstn : int -> 'a list -> 'a list
-val list_last : 'a list -> 'a
-val list_lastn : int -> 'a list -> 'a list
-val list_skipn : int -> 'a list -> 'a list
-val list_skipn_at_least : int -> 'a list -> 'a list
-val list_addn : int -> 'a -> 'a list -> 'a list
-val list_prefix_of : 'a list -> 'a list -> bool
-
-(** [list_drop_prefix p l] returns [t] if [l=p++t] else return [l] *)
-val list_drop_prefix : 'a list -> 'a list -> 'a list
-val list_drop_last : 'a list -> 'a list
-
-(** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)] *)
-val list_map_append : ('a -> 'b list) -> 'a list -> 'b list
-val list_join_map : ('a -> 'b list) -> 'a list -> 'b list
-
-(** raises [Invalid_argument] if the two lists don't have the same length *)
-val list_map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
-val list_share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
-
-(** [list_fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
- where [(e_i,k_i)=f e_{i-1} l_i] *)
-val list_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
-val list_fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
-val list_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
-val list_assoc_f : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b
-
-(** A generic cartesian product: for any operator (**),
- [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
- and so on if there are more elements in the lists. *)
-val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
-
-(** [list_cartesians] is an n-ary cartesian product: it iterates
- [list_cartesian] over a list of lists. *)
-val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
-
-(** list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
-val list_combinations : 'a list list -> 'a list list
-val list_combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
-
-(** Keep only those products that do not return None *)
-val list_cartesian_filter :
- ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
-val list_cartesians_filter :
- ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
-
-val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
-val list_factorize_left : ('a * 'b) list -> ('a * 'b list) list
+(** {6 Sets. } *)
-(** {6 Arrays. } *)
+module Set : module type of CSet
-val array_compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
-val array_equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
-val array_exists : ('a -> bool) -> 'a array -> bool
-val array_for_all : ('a -> bool) -> 'a array -> bool
-val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
-val array_for_all3 : ('a -> 'b -> 'c -> bool) ->
- 'a array -> 'b array -> 'c array -> bool
-val array_for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
- 'a array -> 'b array -> 'c array -> 'd array -> bool
-val array_for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
-val array_find_i : (int -> 'a -> bool) -> 'a array -> int option
-val array_hd : 'a array -> 'a
-val array_tl : 'a array -> 'a array
-val array_last : 'a array -> 'a
-val array_cons : 'a -> 'a array -> 'a array
-val array_rev : 'a array -> unit
-val array_fold_right_i :
- (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
-val array_fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
-val array_fold_right2 :
- ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
-val array_fold_left2 :
- ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
-val array_fold_left3 :
- ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
-val array_fold_left2_i :
- (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
-val array_fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
-val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
-val array_app_tl : 'a array -> 'a list -> 'a list
-val array_list_of_tl : 'a array -> 'a list
-val array_map_to_list : ('a -> 'b) -> 'a array -> 'b list
-val array_chop : int -> 'a array -> 'a array * 'a array
-val array_smartmap : ('a -> 'a) -> 'a array -> 'a array
-val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
-val array_map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
-val array_map3 :
- ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
-val array_map_left : ('a -> 'b) -> 'a array -> 'b array
-val array_map_left_pair : ('a -> 'b) -> 'a array -> ('c -> 'd) -> 'c array ->
- 'b array * 'd array
-val array_iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
-val array_fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
-val array_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
-val array_fold_map2' :
- ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
-val array_distinct : 'a array -> bool
-val array_union_map : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
-val array_rev_to_list : 'a array -> 'a list
-val array_filter_along : ('a -> bool) -> 'a list -> 'b array -> 'b array
-val array_filter_with : bool list -> 'a array -> 'a array
+(** {6 Maps. } *)
+
+module Map : module type of CMap
+
+(** {6 Stacks.} *)
+
+module Stack : module type of CStack
(** {6 Streams. } *)
@@ -314,7 +87,7 @@ val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
val const : 'a -> 'b -> 'a
val iterate : ('a -> 'a) -> int -> 'a -> 'a
val repeat : int -> ('a -> unit) -> 'a -> unit
-val iterate_for : int -> int -> (int -> 'a -> 'a) -> 'a -> 'a
+val app_opt : ('a -> 'a) option -> 'a -> 'a
(** {6 Delayed computations. } *)
@@ -322,90 +95,18 @@ type 'a delayed = unit -> 'a
val delayed_force : 'a delayed -> 'a
-(** {6 Misc. } *)
-
-type ('a,'b) union = Inl of 'a | Inr of 'b
-
-module Intset : Set.S with type elt = int
-
-module Intmap : Map.S with type key = int
-
-val intmap_in_dom : int -> 'a Intmap.t -> bool
-val intmap_to_list : 'a Intmap.t -> (int * 'a) list
-val intmap_inv : 'a Intmap.t -> 'a -> int list
-
-val interval : int -> int -> int list
-
-
-(** In [map_succeed f l] an element [a] is removed if [f a] raises
- [Failure _] otherwise behaves as [List.map f l] *)
+(** {6 Enriched exceptions} *)
-val map_succeed : ('a -> 'b) -> 'a list -> 'b list
+type iexn = Exninfo.iexn
-(** {6 Pretty-printing. } *)
+val iraise : iexn -> 'a
-val pr_spc : unit -> std_ppcmds
-val pr_fnl : unit -> std_ppcmds
-val pr_int : int -> std_ppcmds
-val pr_str : string -> std_ppcmds
-val pr_comma : unit -> std_ppcmds
-val pr_semicolon : unit -> std_ppcmds
-val pr_bar : unit -> std_ppcmds
-val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
-val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
-val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
-val nth : int -> std_ppcmds
-
-val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-
-(** unlike all other functions below, [prlist] works lazily.
- if a strict behavior is needed, use [prlist_strict] instead. *)
-val prlist_strict : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val prlist_with_sep :
- (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b list -> std_ppcmds
-val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvect_with_sep :
- (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvecti_with_sep :
- (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
-val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds
-val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds
-val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val surround : std_ppcmds -> std_ppcmds
-
-(** {6 Memoization. } *)
-
-(** General comments on memoization:
- - cache is created whenever the function is supplied (because of
- ML's polymorphic value restriction).
- - cache is never flushed (unless the memoized fun is GC'd)
-
- One cell memory: memorizes only the last call *)
-val memo1_1 : ('a -> 'b) -> ('a -> 'b)
-val memo1_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c)
-
-(** with custom equality (used to deal with various arities) *)
-val memo1_eq : ('a -> 'a -> bool) -> ('a -> 'b) -> ('a -> 'b)
-
-(** Memorizes the last [n] distinct calls. Efficient only for small [n]. *)
-val memon_eq : ('a -> 'a -> bool) -> int -> ('a -> 'b) -> ('a -> 'b)
-
-(** {6 Size of an ocaml value (in words, bytes and kilobytes). } *)
-
-val size_w : 'a -> int
-val size_b : 'a -> int
-val size_kb : 'a -> int
-
-(** {6 Total size of the allocated ocaml heap. } *)
+(** {6 Misc. } *)
-val heap_size : unit -> int
-val heap_size_kb : unit -> int
+type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b
+(** Union type *)
-(** {6 ... } *)
-(** Coq interruption: set the following boolean reference to interrupt Coq
- (it eventually raises [Break], simulating a Ctrl-C) *)
+val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union
-val interrupt : bool ref
-val check_for_interrupt : unit -> unit
+type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a
+(** Used for browsable-until structures. *)
diff --git a/lib/xml_datatype.mli b/lib/xml_datatype.mli
new file mode 100644
index 00000000..f61ba032
--- /dev/null
+++ b/lib/xml_datatype.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** ['a gxml] is the type for semi-structured documents. They generalize
+ XML by allowing any kind of attributes. *)
+type 'a gxml =
+ | Element of (string * 'a * 'a gxml list)
+ | PCData of string
+
+(** [xml] is a semi-structured documents where attributes are association
+ lists from string to string. *)
+type xml = (string * string) list gxml
+
+
diff --git a/lib/xml_lexer.mli b/lib/xml_lexer.mli
index a1ca0576..e61cb055 100644
--- a/lib/xml_lexer.mli
+++ b/lib/xml_lexer.mli
@@ -38,7 +38,7 @@ type token =
type pos = int * int * int * int
val init : Lexing.lexbuf -> unit
-val close : Lexing.lexbuf -> unit
+val close : unit -> unit
val token : Lexing.lexbuf -> token
val pos : Lexing.lexbuf -> pos
-val restore : pos -> unit \ No newline at end of file
+val restore : pos -> unit
diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll
index 5b06e720..a33be9da 100644
--- a/lib/xml_lexer.mll
+++ b/lib/xml_lexer.mll
@@ -20,24 +20,24 @@
open Lexing
type error =
- | EUnterminatedComment
- | EUnterminatedString
- | EIdentExpected
- | ECloseExpected
- | ENodeExpected
- | EAttributeNameExpected
- | EAttributeValueExpected
- | EUnterminatedEntity
+ | EUnterminatedComment
+ | EUnterminatedString
+ | EIdentExpected
+ | ECloseExpected
+ | ENodeExpected
+ | EAttributeNameExpected
+ | EAttributeValueExpected
+ | EUnterminatedEntity
exception Error of error
type pos = int * int * int * int
type token =
- | Tag of string * (string * string) list * bool
- | PCData of string
- | Endtag of string
- | Eof
+ | Tag of string * (string * string) list * bool
+ | PCData of string
+ | Endtag of string
+ | Eof
let last_pos = ref 0
and current_line = ref 0
@@ -48,39 +48,40 @@ let tmp = Buffer.create 200
let idents = Hashtbl.create 0
let _ = begin
- Hashtbl.add idents "gt;" ">";
- Hashtbl.add idents "lt;" "<";
- Hashtbl.add idents "amp;" "&";
- Hashtbl.add idents "apos;" "'";
- Hashtbl.add idents "quot;" "\"";
+ Hashtbl.add idents "nbsp;" " ";
+ Hashtbl.add idents "gt;" ">";
+ Hashtbl.add idents "lt;" "<";
+ Hashtbl.add idents "amp;" "&";
+ Hashtbl.add idents "apos;" "'";
+ Hashtbl.add idents "quot;" "\"";
end
let init lexbuf =
- current_line := 1;
- current_line_start := lexeme_start lexbuf;
- last_pos := !current_line_start
+ current_line := 1;
+ current_line_start := lexeme_start lexbuf;
+ last_pos := !current_line_start
let close lexbuf =
- Buffer.reset tmp
+ Buffer.reset tmp
let pos lexbuf =
- !current_line , !current_line_start ,
- !last_pos ,
- lexeme_start lexbuf
+ !current_line , !current_line_start ,
+ !last_pos ,
+ lexeme_start lexbuf
let restore (cl,cls,lp,_) =
- current_line := cl;
- current_line_start := cls;
- last_pos := lp
+ current_line := cl;
+ current_line_start := cls;
+ last_pos := lp
let newline lexbuf =
- incr current_line;
- last_pos := lexeme_end lexbuf;
- current_line_start := !last_pos
+ incr current_line;
+ last_pos := lexeme_end lexbuf;
+ current_line_start := !last_pos
let error lexbuf e =
- last_pos := lexeme_start lexbuf;
- raise (Error e)
+ last_pos := lexeme_start lexbuf;
+ raise (Error e)
}
@@ -92,100 +93,100 @@ let entitychar = ['A'-'Z' 'a'-'z']
let pcchar = [^ '\r' '\n' '<' '>' '&']
rule token = parse
- | newline | (newline break) | break
- {
- newline lexbuf;
+ | newline | (newline break) | break
+ {
+ newline lexbuf;
PCData "\n"
- }
- | "<!--"
- {
- last_pos := lexeme_start lexbuf;
- comment lexbuf;
- token lexbuf
- }
- | "<?"
- {
- last_pos := lexeme_start lexbuf;
- header lexbuf;
- token lexbuf;
- }
- | '<' space* '/' space*
- {
- last_pos := lexeme_start lexbuf;
- let tag = ident_name lexbuf in
- ignore_spaces lexbuf;
- close_tag lexbuf;
- Endtag tag
- }
- | '<' space*
- {
- last_pos := lexeme_start lexbuf;
- let tag = ident_name lexbuf in
- ignore_spaces lexbuf;
- let attribs, closed = attributes lexbuf in
- Tag(tag, attribs, closed)
- }
- | "&#"
- {
- last_pos := lexeme_start lexbuf;
- Buffer.reset tmp;
- Buffer.add_string tmp (lexeme lexbuf);
- PCData (pcdata lexbuf)
- }
- | '&'
- {
- last_pos := lexeme_start lexbuf;
- Buffer.reset tmp;
- Buffer.add_string tmp (entity lexbuf);
- PCData (pcdata lexbuf)
- }
- | pcchar+
- {
- last_pos := lexeme_start lexbuf;
- Buffer.reset tmp;
- Buffer.add_string tmp (lexeme lexbuf);
- PCData (pcdata lexbuf)
- }
- | eof { Eof }
- | _
- { error lexbuf ENodeExpected }
+ }
+ | "<!--"
+ {
+ last_pos := lexeme_start lexbuf;
+ comment lexbuf;
+ token lexbuf
+ }
+ | "<?"
+ {
+ last_pos := lexeme_start lexbuf;
+ header lexbuf;
+ token lexbuf;
+ }
+ | '<' space* '/' space*
+ {
+ last_pos := lexeme_start lexbuf;
+ let tag = ident_name lexbuf in
+ ignore_spaces lexbuf;
+ close_tag lexbuf;
+ Endtag tag
+ }
+ | '<' space*
+ {
+ last_pos := lexeme_start lexbuf;
+ let tag = ident_name lexbuf in
+ ignore_spaces lexbuf;
+ let attribs, closed = attributes lexbuf in
+ Tag(tag, attribs, closed)
+ }
+ | "&#"
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (lexeme lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | '&'
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (entity lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | pcchar+
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (lexeme lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | eof { Eof }
+ | _
+ { error lexbuf ENodeExpected }
and ignore_spaces = parse
| newline | (newline break) | break
- {
- newline lexbuf;
- ignore_spaces lexbuf
- }
- | space +
- { ignore_spaces lexbuf }
- | ""
- { () }
+ {
+ newline lexbuf;
+ ignore_spaces lexbuf
+ }
+ | space +
+ { ignore_spaces lexbuf }
+ | ""
+ { () }
and comment = parse
| newline | (newline break) | break
- {
- newline lexbuf;
- comment lexbuf
- }
- | "-->"
- { () }
- | eof
- { raise (Error EUnterminatedComment) }
- | _
- { comment lexbuf }
+ {
+ newline lexbuf;
+ comment lexbuf
+ }
+ | "-->"
+ { () }
+ | eof
+ { raise (Error EUnterminatedComment) }
+ | _
+ { comment lexbuf }
and header = parse
| newline | (newline break) | break
- {
- newline lexbuf;
- header lexbuf
- }
- | "?>"
- { () }
- | eof
- { error lexbuf ECloseExpected }
- | _
- { header lexbuf }
+ {
+ newline lexbuf;
+ header lexbuf
+ }
+ | "?>"
+ { () }
+ | eof
+ { error lexbuf ECloseExpected }
+ | _
+ { header lexbuf }
and pcdata = parse
| newline | (newline break) | break
@@ -194,112 +195,112 @@ and pcdata = parse
newline lexbuf;
pcdata lexbuf
}
- | pcchar+
- {
- Buffer.add_string tmp (lexeme lexbuf);
- pcdata lexbuf
- }
- | "&#"
- {
- Buffer.add_string tmp (lexeme lexbuf);
- pcdata lexbuf;
- }
- | '&'
- {
- Buffer.add_string tmp (entity lexbuf);
- pcdata lexbuf
- }
- | ""
- { Buffer.contents tmp }
+ | pcchar+
+ {
+ Buffer.add_string tmp (lexeme lexbuf);
+ pcdata lexbuf
+ }
+ | "&#"
+ {
+ Buffer.add_string tmp (lexeme lexbuf);
+ pcdata lexbuf;
+ }
+ | '&'
+ {
+ Buffer.add_string tmp (entity lexbuf);
+ pcdata lexbuf
+ }
+ | ""
+ { Buffer.contents tmp }
and entity = parse
- | entitychar+ ';'
- {
- let ident = lexeme lexbuf in
- try
- Hashtbl.find idents (String.lowercase ident)
- with
- Not_found -> "&" ^ ident
- }
- | _ | eof
- { raise (Error EUnterminatedEntity) }
+ | entitychar+ ';'
+ {
+ let ident = lexeme lexbuf in
+ try
+ Hashtbl.find idents (String.lowercase ident)
+ with
+ Not_found -> "&" ^ ident
+ }
+ | _ | eof
+ { raise (Error EUnterminatedEntity) }
and ident_name = parse
- | identchar+
- { lexeme lexbuf }
- | _ | eof
- { error lexbuf EIdentExpected }
+ | identchar+
+ { lexeme lexbuf }
+ | _ | eof
+ { error lexbuf EIdentExpected }
and close_tag = parse
- | '>'
- { () }
- | _ | eof
- { error lexbuf ECloseExpected }
+ | '>'
+ { () }
+ | _ | eof
+ { error lexbuf ECloseExpected }
and attributes = parse
- | '>'
- { [], false }
- | "/>"
- { [], true }
- | "" (* do not read a char ! *)
- {
- let key = attribute lexbuf in
- let data = attribute_data lexbuf in
- ignore_spaces lexbuf;
- let others, closed = attributes lexbuf in
- (key, data) :: others, closed
- }
+ | '>'
+ { [], false }
+ | "/>"
+ { [], true }
+ | "" (* do not read a char ! *)
+ {
+ let key = attribute lexbuf in
+ let data = attribute_data lexbuf in
+ ignore_spaces lexbuf;
+ let others, closed = attributes lexbuf in
+ (key, data) :: others, closed
+ }
and attribute = parse
- | identchar+
- { lexeme lexbuf }
- | _ | eof
- { error lexbuf EAttributeNameExpected }
+ | identchar+
+ { lexeme lexbuf }
+ | _ | eof
+ { error lexbuf EAttributeNameExpected }
and attribute_data = parse
- | space* '=' space* '"'
- {
- Buffer.reset tmp;
- last_pos := lexeme_end lexbuf;
- dq_string lexbuf
- }
- | space* '=' space* '\''
- {
- Buffer.reset tmp;
- last_pos := lexeme_end lexbuf;
- q_string lexbuf
- }
- | _ | eof
- { error lexbuf EAttributeValueExpected }
+ | space* '=' space* '"'
+ {
+ Buffer.reset tmp;
+ last_pos := lexeme_end lexbuf;
+ dq_string lexbuf
+ }
+ | space* '=' space* '\''
+ {
+ Buffer.reset tmp;
+ last_pos := lexeme_end lexbuf;
+ q_string lexbuf
+ }
+ | _ | eof
+ { error lexbuf EAttributeValueExpected }
and dq_string = parse
- | '"'
- { Buffer.contents tmp }
- | '\\' [ '"' '\\' ]
- {
- Buffer.add_char tmp (lexeme_char lexbuf 1);
- dq_string lexbuf
- }
- | eof
- { raise (Error EUnterminatedString) }
- | _
- {
- Buffer.add_char tmp (lexeme_char lexbuf 0);
- dq_string lexbuf
- }
+ | '"'
+ { Buffer.contents tmp }
+ | '\\' [ '"' '\\' ]
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 1);
+ dq_string lexbuf
+ }
+ | eof
+ { raise (Error EUnterminatedString) }
+ | _
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 0);
+ dq_string lexbuf
+ }
and q_string = parse
- | '\''
- { Buffer.contents tmp }
- | '\\' [ '\'' '\\' ]
- {
- Buffer.add_char tmp (lexeme_char lexbuf 1);
- q_string lexbuf
- }
- | eof
- { raise (Error EUnterminatedString) }
- | _
- {
- Buffer.add_char tmp (lexeme_char lexbuf 0);
- q_string lexbuf
- }
+ | '\''
+ { Buffer.contents tmp }
+ | '\\' [ '\'' '\\' ]
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 1);
+ q_string lexbuf
+ }
+ | eof
+ { raise (Error EUnterminatedString) }
+ | _
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 0);
+ q_string lexbuf
+ }
diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml
index 600796f7..8db3f9e8 100644
--- a/lib/xml_parser.ml
+++ b/lib/xml_parser.ml
@@ -19,30 +19,29 @@
*)
open Printf
+open Xml_datatype
-type xml =
- | Element of (string * (string * string) list * xml list)
- | PCData of string
+type xml = Xml_datatype.xml
type error_pos = {
- eline : int;
- eline_start : int;
- emin : int;
- emax : int;
+ eline : int;
+ eline_start : int;
+ emin : int;
+ emax : int;
}
type error_msg =
- | UnterminatedComment
- | UnterminatedString
- | UnterminatedEntity
- | IdentExpected
- | CloseExpected
- | NodeExpected
- | AttributeNameExpected
- | AttributeValueExpected
- | EndOfTagExpected of string
- | EOFExpected
- | Empty
+ | UnterminatedComment
+ | UnterminatedString
+ | UnterminatedEntity
+ | IdentExpected
+ | CloseExpected
+ | NodeExpected
+ | AttributeNameExpected
+ | AttributeValueExpected
+ | EndOfTagExpected of string
+ | EOFExpected
+ | Empty
type error = error_msg * error_pos
@@ -51,21 +50,16 @@ exception Error of error
exception File_not_found of string
type t = {
- mutable check_eof : bool;
- mutable concat_pcdata : bool;
+ mutable check_eof : bool;
+ mutable concat_pcdata : bool;
+ source : Lexing.lexbuf;
+ stack : Xml_lexer.token Stack.t;
}
-type source =
- | SFile of string
- | SChannel of in_channel
- | SString of string
- | SLexbuf of Lexing.lexbuf
-
-type state = {
- source : Lexing.lexbuf;
- stack : Xml_lexer.token Stack.t;
- xparser : t;
-}
+type source =
+ | SChannel of in_channel
+ | SString of string
+ | SLexbuf of Lexing.lexbuf
exception Internal_error of error_msg
exception NoMoreData
@@ -86,152 +80,153 @@ let is_blank s =
!i = len
let _raises e f =
- xml_error := e;
- file_not_found := f
-
-let make () =
- {
- check_eof = true;
- concat_pcdata = true;
- }
+ xml_error := e;
+ file_not_found := f
+
+let make source =
+ let source = match source with
+ | SChannel chan -> Lexing.from_channel chan
+ | SString s -> Lexing.from_string s
+ | SLexbuf lexbuf -> lexbuf
+ in
+ let () = Xml_lexer.init source in
+ {
+ check_eof = false;
+ concat_pcdata = true;
+ source = source;
+ stack = Stack.create ();
+ }
let check_eof p v = p.check_eof <- v
-let concat_pcdata p v = p.concat_pcdata <- v
let pop s =
- try
- Stack.pop s.stack
- with
- Stack.Empty ->
- Xml_lexer.token s.source
+ try
+ Stack.pop s.stack
+ with
+ Stack.Empty ->
+ Xml_lexer.token s.source
let push t s =
- Stack.push t s.stack
+ Stack.push t s.stack
let canonicalize l =
let has_elt = List.exists (function Element _ -> true | _ -> false) l in
if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l
else l
-let rec read_node s =
- match pop s with
- | Xml_lexer.PCData s -> PCData s
- | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
- | Xml_lexer.Tag (tag, attr, false) ->
- let elements = read_elems tag s in
- Element (tag, attr, canonicalize elements)
- | t ->
- push t s;
- raise NoMoreData
-and
- read_elems tag s =
- let elems = ref [] in
- (try
- while true do
- let node = read_node s in
- match node, !elems with
- | PCData c , (PCData c2) :: q ->
- elems := PCData (c2 ^ c) :: q
- | _, l ->
- elems := node :: l
- done
- with
- NoMoreData -> ());
- match pop s with
- | Xml_lexer.Endtag s when s = tag -> List.rev !elems
- | t -> raise (Internal_error (EndOfTagExpected tag))
-
-let rec read_xml s =
- let node = read_node s in
- match node with
- | Element _ -> node
- | PCData c ->
- if is_blank c then read_xml s
- else raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
+let rec read_xml do_not_canonicalize s =
+ let rec read_node s =
+ match pop s with
+ | Xml_lexer.PCData s -> PCData s
+ | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
+ | Xml_lexer.Tag (tag, attr, false) ->
+ let elements = read_elems tag s in
+ let elements =
+ if do_not_canonicalize then elements else canonicalize elements
+ in
+ Element (tag, attr, elements)
+ | t ->
+ push t s;
+ raise NoMoreData
+
+ and read_elems tag s =
+ let elems = ref [] in
+ (try
+ while true do
+ let node = read_node s in
+ match node, !elems with
+ | PCData c , (PCData c2) :: q ->
+ elems := PCData (c2 ^ c) :: q
+ | _, l ->
+ elems := node :: l
+ done
+ with
+ NoMoreData -> ());
+ match pop s with
+ | Xml_lexer.Endtag s when s = tag -> List.rev !elems
+ | t -> raise (Internal_error (EndOfTagExpected tag))
+ in
+ match read_node s with
+ | (Element _) as node ->
+ node
+ | PCData c ->
+ if is_blank c then
+ read_xml do_not_canonicalize s
+ else
+ raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
let convert = function
- | Xml_lexer.EUnterminatedComment -> UnterminatedComment
- | Xml_lexer.EUnterminatedString -> UnterminatedString
- | Xml_lexer.EIdentExpected -> IdentExpected
- | Xml_lexer.ECloseExpected -> CloseExpected
- | Xml_lexer.ENodeExpected -> NodeExpected
- | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
- | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
- | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity
-
-let error_of_exn stk = function
- | NoMoreData when Stack.pop stk = Xml_lexer.Eof -> Empty
+ | Xml_lexer.EUnterminatedComment -> UnterminatedComment
+ | Xml_lexer.EUnterminatedString -> UnterminatedString
+ | Xml_lexer.EIdentExpected -> IdentExpected
+ | Xml_lexer.ECloseExpected -> CloseExpected
+ | Xml_lexer.ENodeExpected -> NodeExpected
+ | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
+ | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
+ | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity
+
+let error_of_exn xparser = function
+ | NoMoreData when pop xparser = Xml_lexer.Eof -> Empty
| NoMoreData -> NodeExpected
| Internal_error e -> e
| Xml_lexer.Error e -> convert e
- | e -> raise e
-
-let do_parse xparser source =
- let stk = Stack.create() in
- try
- Xml_lexer.init source;
- let s = { source = source; xparser = xparser; stack = stk } in
- let x = read_xml s in
- if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
- Xml_lexer.close source;
- x
- with e when e <> Sys.Break ->
- Xml_lexer.close source;
- raise (!xml_error (error_of_exn stk e) source)
-
-let parse p = function
- | SChannel ch -> do_parse p (Lexing.from_channel ch)
- | SString str -> do_parse p (Lexing.from_string str)
- | SLexbuf lex -> do_parse p lex
- | SFile fname ->
- let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in
- try
- let x = do_parse p (Lexing.from_channel ch) in
- close_in ch;
- x
- with
- reraise ->
- close_in ch;
- raise reraise
-
+ | e ->
+ (*let e = Errors.push e in: We do not record backtrace here. *)
+ raise e
+
+let do_parse do_not_canonicalize xparser =
+ try
+ Xml_lexer.init xparser.source;
+ let x = read_xml do_not_canonicalize xparser in
+ if xparser.check_eof && pop xparser <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
+ Xml_lexer.close ();
+ x
+ with any ->
+ Xml_lexer.close ();
+ raise (!xml_error (error_of_exn xparser any) xparser.source)
+
+let parse ?(do_not_canonicalize=false) p =
+ do_parse do_not_canonicalize p
let error_msg = function
- | UnterminatedComment -> "Unterminated comment"
- | UnterminatedString -> "Unterminated string"
- | UnterminatedEntity -> "Unterminated entity"
- | IdentExpected -> "Ident expected"
- | CloseExpected -> "Element close expected"
- | NodeExpected -> "Xml node expected"
- | AttributeNameExpected -> "Attribute name expected"
- | AttributeValueExpected -> "Attribute value expected"
- | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
- | EOFExpected -> "End of file expected"
- | Empty -> "Empty"
+ | UnterminatedComment -> "Unterminated comment"
+ | UnterminatedString -> "Unterminated string"
+ | UnterminatedEntity -> "Unterminated entity"
+ | IdentExpected -> "Ident expected"
+ | CloseExpected -> "Element close expected"
+ | NodeExpected -> "Xml node expected"
+ | AttributeNameExpected -> "Attribute name expected"
+ | AttributeValueExpected -> "Attribute value expected"
+ | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
+ | EOFExpected -> "End of file expected"
+ | Empty -> "Empty"
let error (msg,pos) =
- if pos.emin = pos.emax then
- sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start)
- else
- sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
-
+ if pos.emin = pos.emax then
+ sprintf "%s line %d character %d" (error_msg msg) pos.eline
+ (pos.emin - pos.eline_start)
+ else
+ sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline
+ (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
+
let line e = e.eline
-let range e =
- e.emin - e.eline_start , e.emax - e.eline_start
+let range e =
+ e.emin - e.eline_start , e.emax - e.eline_start
let abs_range e =
- e.emin , e.emax
+ e.emin , e.emax
let pos source =
- let line, lstart, min, max = Xml_lexer.pos source in
- {
- eline = line;
- eline_start = lstart;
- emin = min;
- emax = max;
- }
-
-let () = _raises (fun x p ->
+ let line, lstart, min, max = Xml_lexer.pos source in
+ {
+ eline = line;
+ eline_start = lstart;
+ emin = min;
+ emax = max;
+ }
+
+let () = _raises (fun x p ->
(* local cast : Xml.error_msg -> error_msg *)
- Error (x, pos p))
- (fun f -> File_not_found f)
+ Error (x, pos p))
+ (fun f -> File_not_found f)
diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli
index cc9bcd33..cefb4af8 100644
--- a/lib/xml_parser.mli
+++ b/lib/xml_parser.mli
@@ -27,9 +27,7 @@
(** An Xml node is either
[Element (tag-name, attributes, children)] or [PCData text] *)
-type xml =
- | Element of (string * (string * string) list * xml list)
- | PCData of string
+type xml = Xml_datatype.xml
(** Abstract type for an Xml parser. *)
type t
@@ -59,7 +57,7 @@ type error_msg =
| AttributeValueExpected
| EndOfTagExpected of string
| EOFExpected
- | Empty
+ | Empty
type error = error_msg * error_pos
@@ -71,7 +69,7 @@ exception File_not_found of string
val error : error -> string
(** Get the Xml error message as a string. *)
-val error_msg : error_msg -> string
+val error_msg : error_msg -> string
(** Get the line the error occured at. *)
val line : error_pos -> int
@@ -85,21 +83,24 @@ val abs_range : error_pos -> int * int
val pos : Lexing.lexbuf -> error_pos
(** Several kind of resources can contain Xml documents. *)
-type source =
- | SFile of string
- | SChannel of in_channel
- | SString of string
- | SLexbuf of Lexing.lexbuf
+type source =
+| SChannel of in_channel
+| SString of string
+| SLexbuf of Lexing.lexbuf
(** This function returns a new parser with default options. *)
-val make : unit -> t
+val make : source -> t
-(** When a Xml document is parsed, the parser will check that the end of the
+(** When a Xml document is parsed, the parser may check that the end of the
document is reached, so for example parsing ["<A/><B/>"] will fail instead
- of returning only the A element. You can turn off this check by setting
- [check_eof] to [false] {i (by default, check_eof is true)}. *)
+ of returning only the A element. You can turn on this check by setting
+ [check_eof] to [true] {i (by default, check_eof is false, unlike
+ in the original Xmllight)}. *)
val check_eof : t -> bool -> unit
(** Once the parser is configurated, you can run the parser on a any kind
- of xml document source to parse its contents into an Xml data structure. *)
-val parse : t -> source -> xml
+ of xml document source to parse its contents into an Xml data structure.
+
+ When [do_not_canonicalize] is set, the XML document is given as
+ is, without trying to remove blank PCDATA elements. *)
+val parse : ?do_not_canonicalize:bool -> t -> xml
diff --git a/lib/xml_printer.ml b/lib/xml_printer.ml
new file mode 100644
index 00000000..eeddd53c
--- /dev/null
+++ b/lib/xml_printer.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+type xml = Xml_datatype.xml
+
+type target = TChannel of out_channel | TBuffer of Buffer.t
+
+type t = target
+
+let make x = x
+
+let buffer_pcdata tmp text =
+ let output = Buffer.add_string tmp in
+ let output' = Buffer.add_char tmp in
+ let l = String.length text in
+ for p = 0 to l-1 do
+ match text.[p] with
+ | ' ' -> output "&nbsp;";
+ | '>' -> output "&gt;"
+ | '<' -> output "&lt;"
+ | '&' ->
+ if p < l - 1 && text.[p + 1] = '#' then
+ output' '&'
+ else
+ output "&amp;"
+ | '\'' -> output "&apos;"
+ | '"' -> output "&quot;"
+ | c -> output' c
+ done
+
+let buffer_attr tmp (n,v) =
+ let output = Buffer.add_string tmp in
+ let output' = Buffer.add_char tmp in
+ output' ' ';
+ output n;
+ output "=\"";
+ let l = String.length v in
+ for p = 0 to l - 1 do
+ match v.[p] with
+ | '\\' -> output "\\\\"
+ | '"' -> output "\\\""
+ | c -> output' c
+ done;
+ output' '"'
+
+let to_buffer tmp x =
+ let pcdata = ref false in
+ let output = Buffer.add_string tmp in
+ let output' = Buffer.add_char tmp in
+ let rec loop = function
+ | Element (tag,alist,[]) ->
+ output' '<';
+ output tag;
+ List.iter (buffer_attr tmp) alist;
+ output "/>";
+ pcdata := false;
+ | Element (tag,alist,l) ->
+ output' '<';
+ output tag;
+ List.iter (buffer_attr tmp) alist;
+ output' '>';
+ pcdata := false;
+ List.iter loop l;
+ output "</";
+ output tag;
+ output' '>';
+ pcdata := false;
+ | PCData text ->
+ if !pcdata then output' ' ';
+ buffer_pcdata tmp text;
+ pcdata := true;
+ in
+ loop x
+
+let pcdata_to_string s =
+ let b = Buffer.create 13 in
+ buffer_pcdata b s;
+ Buffer.contents b
+
+let to_string x =
+ let b = Buffer.create 200 in
+ to_buffer b x;
+ Buffer.contents b
+
+let to_string_fmt x =
+ let tmp = Buffer.create 200 in
+ let output = Buffer.add_string tmp in
+ let output' = Buffer.add_char tmp in
+ let rec loop ?(newl=false) tab = function
+ | Element (tag, alist, []) ->
+ output tab;
+ output' '<';
+ output tag;
+ List.iter (buffer_attr tmp) alist;
+ output "/>";
+ if newl then output' '\n';
+ | Element (tag, alist, [PCData text]) ->
+ output tab;
+ output' '<';
+ output tag;
+ List.iter (buffer_attr tmp) alist;
+ output ">";
+ buffer_pcdata tmp text;
+ output "</";
+ output tag;
+ output' '>';
+ if newl then output' '\n';
+ | Element (tag, alist, l) ->
+ output tab;
+ output' '<';
+ output tag;
+ List.iter (buffer_attr tmp) alist;
+ output ">\n";
+ List.iter (loop ~newl:true (tab^" ")) l;
+ output tab;
+ output "</";
+ output tag;
+ output' '>';
+ if newl then output' '\n';
+ | PCData text ->
+ buffer_pcdata tmp text;
+ if newl then output' '\n';
+ in
+ loop "" x;
+ Buffer.contents tmp
+
+let print t xml =
+ let tmp, flush = match t with
+ | TChannel oc ->
+ let b = Buffer.create 200 in
+ b, (fun () -> Buffer.output_buffer oc b; flush oc)
+ | TBuffer b ->
+ b, (fun () -> ())
+ in
+ to_buffer tmp xml;
+ flush ()
diff --git a/lib/xml_printer.mli b/lib/xml_printer.mli
new file mode 100644
index 00000000..e21eca28
--- /dev/null
+++ b/lib/xml_printer.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type xml = Xml_datatype.xml
+
+type t
+type target = TChannel of out_channel | TBuffer of Buffer.t
+
+val make : target -> t
+
+(** Print the xml data structure to a source into a compact xml string (without
+ any user-readable formating ). *)
+val print : t -> xml -> unit
+
+(** Print the xml data structure into a compact xml string (without
+ any user-readable formating ). *)
+val to_string : xml -> string
+
+(** Print the xml data structure into an user-readable string with
+ tabs and lines break between different nodes. *)
+val to_string_fmt : xml -> string
+
+(** Print PCDATA as a string by escaping XML entities. *)
+val pcdata_to_string : string -> string
diff --git a/lib/xml_utils.ml b/lib/xml_utils.ml
deleted file mode 100644
index 31003586..00000000
--- a/lib/xml_utils.ml
+++ /dev/null
@@ -1,223 +0,0 @@
-(*
- * Xml Light, an small Xml parser/printer with DTD support.
- * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- *)
-
-open Printf
-open Xml_parser
-
-exception Not_element of xml
-exception Not_pcdata of xml
-exception No_attribute of string
-
-let default_parser = Xml_parser.make()
-
-let parse (p:Xml_parser.t) (source:Xml_parser.source) =
- (* local cast Xml.xml -> xml *)
- (Obj.magic Xml_parser.parse p source : xml)
-
-let parse_in ch = parse default_parser (Xml_parser.SChannel ch)
-let parse_string str = parse default_parser (Xml_parser.SString str)
-
-let parse_file f = parse default_parser (Xml_parser.SFile f)
-
-let tag = function
- | Element (tag,_,_) -> tag
- | x -> raise (Not_element x)
-
-let pcdata = function
- | PCData text -> text
- | x -> raise (Not_pcdata x)
-
-let attribs = function
- | Element (_,attr,_) -> attr
- | x -> raise (Not_element x)
-
-let attrib x att =
- match x with
- | Element (_,attr,_) ->
- (try
- let att = String.lowercase att in
- snd (List.find (fun (n,_) -> String.lowercase n = att) attr)
- with
- Not_found ->
- raise (No_attribute att))
- | x ->
- raise (Not_element x)
-
-let children = function
- | Element (_,_,clist) -> clist
- | x -> raise (Not_element x)
-
-(*let enum = function
- | Element (_,_,clist) -> List.to_enum clist
- | x -> raise (Not_element x)
-*)
-
-let iter f = function
- | Element (_,_,clist) -> List.iter f clist
- | x -> raise (Not_element x)
-
-let map f = function
- | Element (_,_,clist) -> List.map f clist
- | x -> raise (Not_element x)
-
-let fold f v = function
- | Element (_,_,clist) -> List.fold_left f v clist
- | x -> raise (Not_element x)
-
-let tmp = Buffer.create 200
-
-let buffer_pcdata text =
- let l = String.length text in
- for p = 0 to l-1 do
- match text.[p] with
- | '>' -> Buffer.add_string tmp "&gt;"
- | '<' -> Buffer.add_string tmp "&lt;"
- | '&' ->
- if p < l-1 && text.[p+1] = '#' then
- Buffer.add_char tmp '&'
- else
- Buffer.add_string tmp "&amp;"
- | '\'' -> Buffer.add_string tmp "&apos;"
- | '"' -> Buffer.add_string tmp "&quot;"
- | c -> Buffer.add_char tmp c
- done
-
-let print_pcdata chan text =
- let l = String.length text in
- for p = 0 to l-1 do
- match text.[p] with
- | '>' -> Printf.fprintf chan "&gt;"
- | '<' -> Printf.fprintf chan "&lt;"
- | '&' ->
- if p < l-1 && text.[p+1] = '#' then
- Printf.fprintf chan "&"
- else
- Printf.fprintf chan "&amp;"
- | '\'' -> Printf.fprintf chan "&apos;"
- | '"' -> Printf.fprintf chan "&quot;"
- | c -> Printf.fprintf chan "%c" c
- done
-
-let buffer_attr (n,v) =
- Buffer.add_char tmp ' ';
- Buffer.add_string tmp n;
- Buffer.add_string tmp "=\"";
- let l = String.length v in
- for p = 0 to l-1 do
- match v.[p] with
- | '\\' -> Buffer.add_string tmp "\\\\"
- | '"' -> Buffer.add_string tmp "\\\""
- | c -> Buffer.add_char tmp c
- done;
- Buffer.add_char tmp '"'
-
-let rec print_attr chan (n, v) =
- Printf.fprintf chan " %s=\"" n;
- let l = String.length v in
- for p = 0 to l-1 do
- match v.[p] with
- | '\\' -> Printf.fprintf chan "\\\\"
- | '"' -> Printf.fprintf chan "\\\""
- | c -> Printf.fprintf chan "%c" c
- done;
- Printf.fprintf chan "\""
-
-let print_attrs chan l = List.iter (print_attr chan) l
-
-let rec print_xml chan = function
-| Element (tag, alist, []) ->
- Printf.fprintf chan "<%s%a/>" tag print_attrs alist;
-| Element (tag, alist, l) ->
- Printf.fprintf chan "<%s%a>%a</%s>" tag print_attrs alist
- (fun chan -> List.iter (print_xml chan)) l tag
-| PCData text ->
- print_pcdata chan text
-
-let to_string x =
- let pcdata = ref false in
- let rec loop = function
- | Element (tag,alist,[]) ->
- Buffer.add_char tmp '<';
- Buffer.add_string tmp tag;
- List.iter buffer_attr alist;
- Buffer.add_string tmp "/>";
- pcdata := false;
- | Element (tag,alist,l) ->
- Buffer.add_char tmp '<';
- Buffer.add_string tmp tag;
- List.iter buffer_attr alist;
- Buffer.add_char tmp '>';
- pcdata := false;
- List.iter loop l;
- Buffer.add_string tmp "</";
- Buffer.add_string tmp tag;
- Buffer.add_char tmp '>';
- pcdata := false;
- | PCData text ->
- if !pcdata then Buffer.add_char tmp ' ';
- buffer_pcdata text;
- pcdata := true;
- in
- Buffer.reset tmp;
- loop x;
- let s = Buffer.contents tmp in
- Buffer.reset tmp;
- s
-
-let to_string_fmt x =
- let rec loop ?(newl=false) tab = function
- | Element (tag,alist,[]) ->
- Buffer.add_string tmp tab;
- Buffer.add_char tmp '<';
- Buffer.add_string tmp tag;
- List.iter buffer_attr alist;
- Buffer.add_string tmp "/>";
- if newl then Buffer.add_char tmp '\n';
- | Element (tag,alist,[PCData text]) ->
- Buffer.add_string tmp tab;
- Buffer.add_char tmp '<';
- Buffer.add_string tmp tag;
- List.iter buffer_attr alist;
- Buffer.add_string tmp ">";
- buffer_pcdata text;
- Buffer.add_string tmp "</";
- Buffer.add_string tmp tag;
- Buffer.add_char tmp '>';
- if newl then Buffer.add_char tmp '\n';
- | Element (tag,alist,l) ->
- Buffer.add_string tmp tab;
- Buffer.add_char tmp '<';
- Buffer.add_string tmp tag;
- List.iter buffer_attr alist;
- Buffer.add_string tmp ">\n";
- List.iter (loop ~newl:true (tab^" ")) l;
- Buffer.add_string tmp tab;
- Buffer.add_string tmp "</";
- Buffer.add_string tmp tag;
- Buffer.add_char tmp '>';
- if newl then Buffer.add_char tmp '\n';
- | PCData text ->
- buffer_pcdata text;
- if newl then Buffer.add_char tmp '\n';
- in
- Buffer.reset tmp;
- loop "" x;
- let s = Buffer.contents tmp in
- Buffer.reset tmp;
- s
diff --git a/lib/xml_utils.mli b/lib/xml_utils.mli
deleted file mode 100644
index 4a4a1309..00000000
--- a/lib/xml_utils.mli
+++ /dev/null
@@ -1,93 +0,0 @@
-(*
- * Xml Light, an small Xml parser/printer with DTD support.
- * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- *)
-
-(** Xml Light
-
- Xml Light is a minimal Xml parser & printer for OCaml.
- It provide few functions to parse a basic Xml document into
- an OCaml data structure and to print back the data structures
- to an Xml document.
-
- Xml Light has also support for {b DTD} (Document Type Definition).
-
- {i (c)Copyright 2002-2003 Nicolas Cannasse}
-*)
-
-open Xml_parser
-
-(** {6 Xml Functions} *)
-
-exception Not_element of xml
-exception Not_pcdata of xml
-exception No_attribute of string
-
-(** [tag xdata] returns the tag value of the xml node.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val tag : xml -> string
-
-(** [pcdata xdata] returns the PCData value of the xml node.
- Raise {!Xml.Not_pcdata} if the xml is not a PCData *)
-val pcdata : xml -> string
-
-(** [attribs xdata] returns the attribute list of the xml node.
- First string if the attribute name, second string is attribute value.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val attribs : xml -> (string * string) list
-
-(** [attrib xdata "href"] returns the value of the ["href"]
- attribute of the xml node (attribute matching is case-insensitive).
- Raise {!Xml.No_attribute} if the attribute does not exists in the node's
- attribute list
- Raise {!Xml.Not_element} if the xml is not an element *)
-val attrib : xml -> string -> string
-
-(** [children xdata] returns the children list of the xml node
- Raise {!Xml.Not_element} if the xml is not an element *)
-val children : xml -> xml list
-
-(*** [enum xdata] returns the children enumeration of the xml node
- Raise {!Xml.Not_element} if the xml is not an element *)
-(* val enum : xml -> xml Enum.t *)
-
-(** [iter f xdata] calls f on all children of the xml node.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val iter : (xml -> unit) -> xml -> unit
-
-(** [map f xdata] is equivalent to [List.map f (Xml.children xdata)]
- Raise {!Xml.Not_element} if the xml is not an element *)
-val map : (xml -> 'a) -> xml -> 'a list
-
-(** [fold f init xdata] is equivalent to
- [List.fold_left f init (Xml.children xdata)]
- Raise {!Xml.Not_element} if the xml is not an element *)
-val fold : ('a -> xml -> 'a) -> 'a -> xml -> 'a
-
-(** {6 Xml Printing} *)
-
-(** Print the xml data structure to a channel into a compact xml string (without
- any user-readable formating ). *)
-val print_xml : out_channel -> xml -> unit
-
-(** Print the xml data structure into a compact xml string (without
- any user-readable formating ). *)
-val to_string : xml -> string
-
-(** Print the xml data structure into an user-readable string with
- tabs and lines break between different nodes. *)
-val to_string_fmt : xml -> string