From 9043add656177eeac1491a73d2f3ab92bec0013c Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Sat, 29 Dec 2018 14:31:27 -0500 Subject: Imported Upstream version 8.8.2 --- lib/aux_file.ml | 41 +- lib/aux_file.mli | 18 +- lib/backtrace.ml | 116 --- lib/backtrace.mli | 96 -- lib/bigint.ml | 524 ---------- lib/bigint.mli | 44 - lib/cArray.ml | 532 ---------- lib/cArray.mli | 137 --- lib/cAst.ml | 26 + lib/cAst.mli | 24 + lib/cEphemeron.ml | 89 -- lib/cEphemeron.mli | 52 - lib/cErrors.ml | 69 +- lib/cErrors.mli | 54 +- lib/cList.ml | 836 --------------- lib/cList.mli | 239 ----- lib/cMap.ml | 218 ---- lib/cMap.mli | 88 -- lib/cObj.ml | 203 ---- lib/cObj.mli | 59 -- lib/cProfile.ml | 716 +++++++++++++ lib/cProfile.mli | 121 +++ lib/cSet.ml | 67 -- lib/cSet.mli | 31 - lib/cSig.mli | 82 -- lib/cStack.ml | 42 - lib/cStack.mli | 56 - lib/cString.ml | 181 ---- lib/cString.mli | 78 -- lib/cThread.ml | 95 -- lib/cThread.mli | 26 - lib/cUnix.ml | 139 --- lib/cUnix.mli | 66 -- lib/cWarnings.ml | 90 +- lib/cWarnings.mli | 14 +- lib/canary.ml | 26 - lib/canary.mli | 25 - lib/clib.mllib | 37 - lib/control.ml | 42 +- lib/control.mli | 25 +- lib/coqProject_file.ml4 | 255 +++++ lib/coqProject_file.mli | 68 ++ lib/dAst.ml | 43 + lib/dAst.mli | 30 + lib/deque.ml | 97 -- lib/deque.mli | 58 -- lib/doc.tex | 7 - lib/dyn.ml | 148 --- lib/dyn.mli | 63 -- lib/envars.ml | 114 ++- lib/envars.mli | 39 +- lib/exninfo.ml | 104 -- lib/exninfo.mli | 39 - lib/explore.ml | 12 +- lib/explore.mli | 12 +- lib/feedback.ml | 265 ++--- lib/feedback.mli | 102 +- lib/flags.ml | 174 +--- lib/flags.mli | 107 +- lib/future.ml | 102 +- lib/future.mli | 92 +- lib/genarg.ml | 33 +- lib/genarg.mli | 15 +- lib/hMap.ml | 406 -------- lib/hMap.mli | 28 - lib/hashcons.ml | 182 ---- lib/hashcons.mli | 90 -- lib/hashset.ml | 229 ----- lib/hashset.mli | 56 - lib/heap.ml | 134 --- lib/heap.mli | 52 - lib/hook.ml | 10 +- lib/hook.mli | 10 +- lib/iStream.ml | 90 -- lib/iStream.mli | 81 -- lib/int.ml | 237 ----- lib/int.mli | 79 -- lib/lib.mllib | 38 +- lib/loc.ml | 59 +- lib/loc.mli | 56 +- lib/minisys.ml | 66 -- lib/monad.ml | 168 --- lib/monad.mli | 93 -- lib/option.ml | 191 ---- lib/option.mli | 126 --- lib/pp.ml | 338 ++---- lib/pp.mli | 226 ++-- lib/pp_control.ml | 93 -- lib/pp_control.mli | 38 - lib/ppstyle.ml | 73 -- lib/ppstyle.mli | 63 -- lib/predicate.ml | 98 -- lib/predicate.mli | 84 -- lib/profile.ml | 713 ------------- lib/profile.mli | 119 --- lib/remoteCounter.ml | 14 +- lib/remoteCounter.mli | 10 +- lib/richpp.ml | 196 ---- lib/richpp.mli | 64 -- lib/rtree.ml | 10 +- lib/rtree.mli | 12 +- lib/segmenttree.ml | 130 --- lib/segmenttree.mli | 20 - lib/spawn.ml | 20 +- lib/spawn.mli | 14 +- lib/stateid.ml | 13 +- lib/stateid.mli | 12 +- lib/store.ml | 91 -- lib/store.mli | 46 - lib/system.ml | 50 +- lib/system.mli | 23 +- lib/terminal.ml | 288 ------ lib/terminal.mli | 64 -- lib/trie.ml | 89 -- lib/trie.mli | 61 -- lib/unicode.ml | 331 ------ lib/unicode.mli | 42 - lib/unicodetable.ml | 2619 ----------------------------------------------- lib/unionfind.ml | 136 --- lib/unionfind.mli | 80 -- lib/util.ml | 49 +- lib/util.mli | 29 +- lib/xml_datatype.mli | 10 +- 123 files changed, 2333 insertions(+), 13919 deletions(-) delete mode 100644 lib/backtrace.ml delete mode 100644 lib/backtrace.mli delete mode 100644 lib/bigint.ml delete mode 100644 lib/bigint.mli delete mode 100644 lib/cArray.ml delete mode 100644 lib/cArray.mli create mode 100644 lib/cAst.ml create mode 100644 lib/cAst.mli delete mode 100644 lib/cEphemeron.ml delete mode 100644 lib/cEphemeron.mli delete mode 100644 lib/cList.ml delete mode 100644 lib/cList.mli delete mode 100644 lib/cMap.ml delete mode 100644 lib/cMap.mli delete mode 100644 lib/cObj.ml delete mode 100644 lib/cObj.mli create mode 100644 lib/cProfile.ml create mode 100644 lib/cProfile.mli delete mode 100644 lib/cSet.ml delete mode 100644 lib/cSet.mli delete mode 100644 lib/cSig.mli delete mode 100644 lib/cStack.ml delete mode 100644 lib/cStack.mli delete mode 100644 lib/cString.ml delete mode 100644 lib/cString.mli delete mode 100644 lib/cThread.ml delete mode 100644 lib/cThread.mli delete mode 100644 lib/cUnix.ml delete mode 100644 lib/cUnix.mli delete mode 100644 lib/canary.ml delete mode 100644 lib/canary.mli delete mode 100644 lib/clib.mllib create mode 100644 lib/coqProject_file.ml4 create mode 100644 lib/coqProject_file.mli create mode 100644 lib/dAst.ml create mode 100644 lib/dAst.mli delete mode 100644 lib/deque.ml delete mode 100644 lib/deque.mli delete mode 100644 lib/doc.tex delete mode 100644 lib/dyn.ml delete mode 100644 lib/dyn.mli delete mode 100644 lib/exninfo.ml delete mode 100644 lib/exninfo.mli delete mode 100644 lib/hMap.ml delete mode 100644 lib/hMap.mli delete mode 100644 lib/hashcons.ml delete mode 100644 lib/hashcons.mli delete mode 100644 lib/hashset.ml delete mode 100644 lib/hashset.mli delete mode 100644 lib/heap.ml delete mode 100644 lib/heap.mli delete mode 100644 lib/iStream.ml delete mode 100644 lib/iStream.mli delete mode 100644 lib/int.ml delete mode 100644 lib/int.mli delete mode 100644 lib/minisys.ml delete mode 100644 lib/monad.ml delete mode 100644 lib/monad.mli delete mode 100644 lib/option.ml delete mode 100644 lib/option.mli delete mode 100644 lib/pp_control.ml delete mode 100644 lib/pp_control.mli delete mode 100644 lib/ppstyle.ml delete mode 100644 lib/ppstyle.mli delete mode 100644 lib/predicate.ml delete mode 100644 lib/predicate.mli delete mode 100644 lib/profile.ml delete mode 100644 lib/profile.mli delete mode 100644 lib/richpp.ml delete mode 100644 lib/richpp.mli delete mode 100644 lib/segmenttree.ml delete mode 100644 lib/segmenttree.mli delete mode 100644 lib/store.ml delete mode 100644 lib/store.mli delete mode 100644 lib/terminal.ml delete mode 100644 lib/terminal.mli delete mode 100644 lib/trie.ml delete mode 100644 lib/trie.mli delete mode 100644 lib/unicode.ml delete mode 100644 lib/unicode.mli delete mode 100644 lib/unicodetable.ml delete mode 100644 lib/unionfind.ml delete mode 100644 lib/unionfind.mli (limited to 'lib') diff --git a/lib/aux_file.ml b/lib/aux_file.ml index 0f0f09aa..0f947660 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let i, j = Loc.unloc loc in - Printf.fprintf oc "%d %d %s %S\n" i j key v) - !oc + match loc with + | Some loc -> let i, j = Loc.unloc loc in + Printf.fprintf oc "%d %d %s %S\n" i j key v + | None -> Printf.fprintf oc "0 0 %s %S\n" key v + ) !oc -let current_loc = ref Loc.ghost +let current_loc : Loc.t option ref = ref None -let record_in_aux_set_at loc = current_loc := loc +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 record_in_aux key v = record_in_aux_at ?loc:!current_loc key v let set h loc k v = let m = try H.find loc h with Not_found -> M.empty in @@ -76,14 +76,15 @@ let load_aux_file_for vfile = 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 + let ib = Scanf.Scanning.from_channel (open_in aux_fname) in + let ver, hash, fname = + Scanf.bscanf ib "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 + let i, j, k, v = Scanf.bscanf ib "%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 @@ -94,4 +95,4 @@ let load_aux_file_for vfile = Flags.if_verbose Feedback.msg_info 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 +let set ?loc h k v = set h (Option.cata Loc.unloc (0,0) loc) k v diff --git a/lib/aux_file.mli b/lib/aux_file.mli index 86e322b7..efdd75fd 100644 --- a/lib/aux_file.mli +++ b/lib/aux_file.mli @@ -1,17 +1,19 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 get : ?loc:Loc.t -> aux_file -> string -> string +val set : ?loc:Loc.t -> aux_file -> string -> string -> aux_file module H : Map.S with type key = int * int module M : Map.S with type key = string @@ -22,6 +24,6 @@ val start_aux_file : aux_file:string -> v_file: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_at : ?loc:Loc.t -> string -> string -> unit val record_in_aux : string -> string -> unit -val record_in_aux_set_at : Loc.t -> unit +val record_in_aux_set_at : ?loc:Loc.t -> unit -> unit diff --git a/lib/backtrace.ml b/lib/backtrace.ml deleted file mode 100644 index b3b8bdea..00000000 --- a/lib/backtrace.ml +++ /dev/null @@ -1,116 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index dd82165b..00000000 --- a/lib/backtrace.mli +++ /dev/null @@ -1,96 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index e95604ff..00000000 --- a/lib/bigint.ml +++ /dev/null @@ -1,524 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let rec aux j l n = - 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 *) -let base = - let rec exp10 = function 0 -> 1 | n -> 10 * exp10 (n-1) in exp10 size - -(******************************************************************) -(* First, we represent all numbers by int arrays. - Later, we will optimize the particular case of small integers *) -(******************************************************************) - -module ArrayInt = struct - -(* Basic numbers *) -let zero = [||] - -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 = (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 - (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 && Int.equal n.(!k) 0 do incr k done; - Array.sub n !k (Array.length n - !k) - -(* [normalize_neg] : avoid (-1) as first bloc. - input: an array with -1 as first bloc and other blocs in [0;base[ - output: a canonical array *) - -let normalize_neg n = - let k = ref 1 in - 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 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 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 is_zero m then zero else - let n = Array.copy m in - let i = ref (Array.length m - 1) in - 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 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 *) - n.(!i) <- base - n.(!i); decr i; - while !i > 0 do n.(!i) <- base - 1 - n.(!i); decr i done; - (* since -base <= n.(0) <= base-1, hence -base <= -n.(0)-1 <= base-1 *) - n.(0) <- - n.(0) - 1; - (* since m is canonical, m.(0)<>0 hence n.(0)<>-1, - and m=-1 is already handled above, so here m.(0)<>-1 hence n.(0)<>0 *) - n - end - -let push_carry r j = - let j = ref j in - 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 - r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1 - done; - (* here r.(0) could be in [-2*base;2*base-1] *) - if r.(0) >= base then (r.(0) <- r.(0) - base; Array.append [| 1 |] r) - else if r.(0) < -base then (r.(0) <- r.(0) + 2*base; Array.append [| -2 |] r) - else normalize r (* in case r.(0) is 0 or -1 *) - -let add_to r a j = - 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) - done; - r.(j) <- r.(j) + a.(0); - push_carry r j - end - -let add n m = - let d = Array.length n - Array.length m in - 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 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) - done; - r.(j) <- r.(j) - a.(0); - push_carry r j - end - -let sub n m = - let d = Array.length n - Array.length m in - 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 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.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 - let (q,s) = - if p < 0 - then (p + 1) / base - 1, (p + 1) mod base + base - 1 - else p / base, p mod base in - r.(i+j+1) <- s; - if not (Int.equal q 0) then r.(i+j) <- r.(i+j) + q; - done - done; - normalize r - -(* Comparisons *) - -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) || (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 || 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 || - (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 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) - || (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 = - (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 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; - if m.(k+i) < 0 then (m.(k+i) <- m.(k+i) + base; m.(k+i-1) <- m.(k+i-1) -1); - if v >= base then begin - m.(k+i-1) <- m.(k+i-1) - v / base; - let j = ref (i-1) in - while m.(k + !j) < 0 do (* result is positive, hence !j remains >= 0 *) - m.(k + !j) <- m.(k + !j) + base; decr j; m.(k + !j) <- m.(k + !j) -1 - done - end - done - -(** Euclid division m/d = (q,r) - This is the "Floor" variant, as with ocaml's / - (but not as ocaml's Big_int.quomod_big_int). - We have sign r = sign m *) - -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 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.make (ql+1) 0 in - let i = ref 0 in - while not (less_than_shift_pos !i m d) do - 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 && 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 - q.(!i) <- q.(!i) + v; - sub_mult m d v !i - end else begin - let v = (m.(!i) * base + m.(!i+1)) / (d.(0) + 1) in - q.(!i) <- q.(!i) + v / base; - sub_mult m d (v / base) !i; - q.(!i+1) <- q.(!i+1) + v mod base; - if q.(!i+1) >= base then - (q.(!i+1) <- q.(!i+1)-base; q.(!i) <- q.(!i)+1); - sub_mult m d (v mod base) (!i+1) - end - done; - (normalize q, normalize m) in - (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 d = ref (if isneg then 1 else 0) in - 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 = match h with "" -> 0 | _ -> 1 in - let l = (len - !d) / size in - 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 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))) - -let to_string n = - if is_strictly_neg n then to_string_pos "-" (neg n) - else to_string_pos "" n - -end - -(******************************************************************) -(* Optimized operations on (unbounded) integer numbers *) -(* integers smaller than base are represented as machine integers *) -(******************************************************************) - -open ArrayInt - -type bigint = Obj.t - -(* Since base is the largest power of 10 such that base*base <= max_int, - we have max_int < 100*base*base : any int can be represented - by at most three blocs *) - -let small n = (-base <= n) && (n < base) - -let mkarray n = - (* n isn't small, this case is handled separately below *) - let lo = n mod base - and hi = n / base in - let t = if small hi then [|hi;lo|] else [|hi/base;hi mod base;lo|] - in - for i = Array.length t -1 downto 1 do - if t.(i) < 0 then (t.(i) <- t.(i) + base; t.(i-1) <- t.(i-1) -1) - done; - t - -let ints_of_int n = - if Int.equal n 0 then [| |] - else if small n then [| n |] - else mkarray n - -let of_int n = - if small n then Obj.repr n else Obj.repr (mkarray n) - -let of_ints n = - let n = normalize n in (* TODO: using normalize here seems redundant now *) - 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) -let coerce_to_ints = (Obj.magic : Obj.t -> int array) - -let to_ints n = - if Obj.is_int n then ints_of_int (coerce_to_int n) - else coerce_to_ints n - -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) || (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 - for i = l-1 downto 0 do - sum := !sum + t.(i) * !pow; - pow := !pow*base; - done; - !sum - -let to_int n = - if Obj.is_int n then coerce_to_int n - else int_of_ints (coerce_to_ints n) - -let app_pair f (m, n) = - (f m, f n) - -let add m 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 - 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 - 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 - 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 - then coerce_to_int m < coerce_to_int n - else less_than (to_ints m) (to_ints n) - -let neg n = - if Obj.is_int n then of_int (- (coerce_to_int n)) - else of_ints (neg (to_ints n)) - -let of_string m = of_ints (of_string m) -let to_string m = to_string (to_ints m) - -let zero = of_int 0 -let one = of_int 1 -let two = of_int 2 -let sub_1 n = sub n one -let add_1 n = add n one -let mult_2 n = add n n - -let div2_with_rest n = - let (q,b) = euclid n two in - (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 = - 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 *) -(* In practice the algorithm performs : - k*n^0 = k - k*n^(2m) = k*(n*n)^m - k*n^(2m+1) = (n*k)*(n*n)^m *) -let pow = - let rec pow_aux odd_rest n m = (* odd_rest is the k from above *) - if m<=0 then - odd_rest - else - let quo = m lsr 1 (* i.e. m/2 *) - 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) - quo - in - pow_aux one - -(** Testing suite w.r.t. OCaml's Big_int *) - -(* -module B = struct - open Big_int - let zero = zero_big_int - let to_string = string_of_big_int - let of_string = big_int_of_string - let add = add_big_int - let opp = minus_big_int - let sub = sub_big_int - let mul = mult_big_int - let abs = abs_big_int - let sign = sign_big_int - let euclid n m = - let n' = abs n and m' = abs m in - let q',r' = quomod_big_int n' m' in - (if sign (mul n m) < 0 && sign q' <> 0 then opp q' else q'), - (if sign n < 0 then opp r' else r') -end - -let check () = - let roots = [ 1; 100; base; 100*base; base*base ] in - let rands = [ 1234; 5678; 12345678; 987654321 ] in - let nums = (List.flatten (List.map (fun x -> [x-1;x;x+1]) roots)) @ rands in - let numbers = - List.map string_of_int nums @ - List.map (fun n -> string_of_int (-n)) nums - in - let i = ref 0 in - let compare op x y n n' = - incr i; - let s = Printf.sprintf "%30s" (to_string n) in - let s' = Printf.sprintf "%30s" (B.to_string n') in - if s <> s' then Printf.printf "%s%s%s: %s <> %s\n" x op y s s' in - let test x y = - let n = of_string x and m = of_string y in - let n' = B.of_string x and m' = B.of_string y in - let a = add n m and a' = B.add n' m' in - let s = sub n m and s' = B.sub n' m' in - let p = mult n m and p' = B.mul n' m' in - let q,r = try euclid n m with Division_by_zero -> zero,zero - and q',r' = try B.euclid n' m' with Division_by_zero -> B.zero, B.zero - in - compare "+" x y a a'; - compare "-" x y s s'; - compare "*" x y p p'; - compare "/" x y q q'; - compare "%" x y r r' - in - List.iter (fun a -> List.iter (test a) numbers) numbers; - Printf.printf "%i tests done\n" !i -*) diff --git a/lib/bigint.mli b/lib/bigint.mli deleted file mode 100644 index e5525f16..00000000 --- a/lib/bigint.mli +++ /dev/null @@ -1,44 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bigint -(** May raise a Failure just as [int_of_string] on non-numerical strings *) - -val to_string : bigint -> string - -val of_int : int -> bigint -val to_int : bigint -> int (** May raise a Failure on oversized numbers *) - -val zero : bigint -val one : bigint -val two : bigint - -val div2_with_rest : bigint -> bigint * bool (** true=odd; false=even *) -val add_1 : bigint -> bigint -val sub_1 : bigint -> bigint -val mult_2 : bigint -> bigint - -val add : bigint -> bigint -> bigint -val sub : bigint -> bigint -> bigint -val mult : bigint -> bigint -> bigint -val euclid : bigint -> bigint -> bigint * bigint - -val less_than : bigint -> bigint -> bool -val equal : bigint -> bigint -> bool - -val is_strictly_pos : bigint -> bool -val is_strictly_neg : bigint -> bool -val is_pos_or_zero : bigint -> bool -val is_neg_or_zero : bigint -> bool -val neg : bigint -> bigint - -val pow : bigint -> int -> bigint diff --git a/lib/cArray.ml b/lib/cArray.ml deleted file mode 100644 index bb1e3354..00000000 --- a/lib/cArray.ml +++ /dev/null @@ -1,532 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -> int) -> 'a array -> 'a array -> int - val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool - val equal_norefl : ('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_norefl cmp t1 t2 = - 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 equal cmp t1 t2 = - if t1 == t2 then true else equal_norefl cmp t1 t2 - - -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 deleted file mode 100644 index 7e5c93b5..00000000 --- a/lib/cArray.mli +++ /dev/null @@ -1,137 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 equal_norefl : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool - (** Like {!equal} but does not assume that equality is reflexive: no - optimisation is performed if both arrays are physically the - same. *) - - 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/cAst.ml b/lib/cAst.ml new file mode 100644 index 00000000..e1da072d --- /dev/null +++ b/lib/cAst.ml @@ -0,0 +1,26 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* 'a -> 'a t + +val map : ('a -> 'b) -> 'a t -> 'b t +val map_with_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a t -> 'b t +val map_from_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a Loc.located -> 'b t + +val with_val : ('a -> 'b) -> 'a t -> 'b +val with_loc_val : (?loc:Loc.t -> 'a -> 'b) -> 'a t -> 'b diff --git a/lib/cEphemeron.ml b/lib/cEphemeron.ml deleted file mode 100644 index a38ea11e..00000000 --- a/lib/cEphemeron.ml +++ /dev/null @@ -1,89 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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/cEphemeron.mli b/lib/cEphemeron.mli deleted file mode 100644 index 1200e4e2..00000000 --- a/lib/cEphemeron.mli +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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/cErrors.ml b/lib/cErrors.ml index 5c56192f..97502211 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -1,10 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raise (Anomaly (label, pp)) - | Some loc -> Loc.raise loc (Anomaly (label, pp)) +let anomaly ?loc ?label pp = + 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)) +exception UserError of string option * Pp.t (* User errors *) 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) +let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm)) + +let invalid_arg ?loc s = Loc.raise ?loc (Invalid_argument s) + +exception AlreadyDeclared of Pp.t (* for already declared Schemes *) +let alreadydeclared pps = raise (AlreadyDeclared(pps)) exception Timeout exception Drop @@ -89,7 +79,7 @@ let where = function if !Flags.debug then str "in " ++ str s ++ str ":" ++ spc () else mt () let raw_anomaly e = match e with - | Anomaly (s, pps) -> where s ++ pps ++ str "." + | Anomaly (s, pps) -> where s ++ pps | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e) ++ str "." | _ -> str "Uncaught exception " ++ str (Printexc.to_string e) ++ str "." @@ -103,9 +93,8 @@ let print_backtrace e = match Backtrace.get_backtrace e with let print_anomaly askreport e = if askreport then - hov 0 (ann_str ++ raw_anomaly e ++ spc () ++ - strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++ - str ".") + hov 0 (str "Anomaly" ++ spc () ++ quote (raw_anomaly e)) ++ spc () ++ + hov 0 (str "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".") else hov 0 (raw_anomaly e) @@ -125,7 +114,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (err_str ++ where (Some s) ++ pps) + hov 0 (where s ++ pps) | _ -> raise Unhandled end @@ -133,12 +122,14 @@ end by inner functions during a [vernacinterp]. They should be handled only at the very end of interp, to be displayed to the user. *) +[@@@ocaml.warning "-52"] let noncritical = function | Sys.Break | Out_of_memory | Stack_overflow | Assert_failure _ | Match_failure _ | Anomaly _ | Timeout | Drop | Quit -> false | Invalid_argument "equal: functional value" -> false | _ -> true +[@@@ocaml.warning "+52"] (** Check whether an exception is handled *) @@ -148,13 +139,3 @@ let handled e = let bottom _ = raise Bottom in try let _ = print_gen bottom !handle_stack e in true with Bottom -> false - -(** Prints info which is either an error or - an anomaly and then exits with the appropriate - error code *) - -let fatal_error info anomaly = - let msg = info ++ fnl () in - pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg; - Format.pp_print_flush !Pp_control.err_ft (); - exit (if anomaly then 129 else 1) diff --git a/lib/cErrors.mli b/lib/cErrors.mli index e5dad93f..ec34dd62 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -1,12 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Exninfo.iexn [Anomaly] is used for system errors and [UserError] for the user's ones. *) -val make_anomaly : ?label:string -> std_ppcmds -> exn +val make_anomaly : ?label:string -> Pp.t -> exn (** Create an anomaly. *) -val anomaly : ?loc:Loc.t -> ?label:string -> std_ppcmds -> 'a +val anomaly : ?loc:Loc.t -> ?label:string -> Pp.t -> 'a (** Raise an anomaly, with an optional location and an optional label identifying the anomaly. *) @@ -33,15 +33,18 @@ val is_anomaly : exn -> bool 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 UserError of string option * Pp.t +(** Main error signaling exception. It carries a header plus a pretty printing + doc *) + +val user_err : ?loc:Loc.t -> ?hdr:string -> Pp.t -> 'a +(** Main error raising primitive. [user_err ?loc ?hdr pp] signals an + error [pp] with optional header and location [hdr] [loc] *) -exception AlreadyDeclared of std_ppcmds -val alreadydeclared : std_ppcmds -> 'a +exception AlreadyDeclared of Pp.t +val alreadydeclared : Pp.t -> 'a -val invalid_arg_loc : Loc.t * string -> '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 @@ -71,16 +74,16 @@ exception Quit exception Unhandled -val register_handler : (exn -> Pp.std_ppcmds) -> unit +val register_handler : (exn -> Pp.t) -> unit (** The standard exception printer *) -val print : ?info:Exninfo.info -> exn -> Pp.std_ppcmds -val iprint : Exninfo.iexn -> Pp.std_ppcmds +val print : ?info:Exninfo.info -> exn -> Pp.t +val iprint : Exninfo.iexn -> Pp.t (** 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 -val iprint_no_report : Exninfo.iexn -> Pp.std_ppcmds +val print_no_report : exn -> Pp.t +val iprint_no_report : Exninfo.iexn -> Pp.t (** Critical exceptions should not be caught and ignored by mistake by inner functions during a [vernacinterp]. They should be handled @@ -92,8 +95,3 @@ val noncritical : exn -> bool (** Check whether an exception is handled by some toplevel printer. The [Anomaly] exception is never handled. *) val handled : exn -> bool - -(** Prints info which is either an error or - an anomaly and then exits with the appropriate - error code *) -val fatal_error : Pp.std_ppcmds -> bool -> 'a diff --git a/lib/cList.ml b/lib/cList.ml deleted file mode 100644 index c8283e3c..00000000 --- a/lib/cList.ml +++ /dev/null @@ -1,836 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 partitioni : - (int -> 'a -> bool) -> 'a list -> 'a list * 'a list - val smartfilter : ('a -> bool) -> 'a list -> 'a list - val extend : bool list -> 'a -> 'a list -> 'a list - val count : ('a -> bool) -> 'a list -> int - 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 extract_first : ('a -> bool) -> 'a list -> 'a list * 'a - 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 extend l a l' = match l,l' with - | true::l, b::l' -> b :: extend l a l' - | false::l, l' -> a :: extend l a l' - | [], [] -> [] - | _ -> invalid_arg "extend" - -let count f l = - let rec aux acc = function - | [] -> acc - | h :: t -> if f h then aux (acc + 1) t else aux acc t in - aux 0 l - -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 extract_first p li = - let rec loop rev_left = function - | [] -> raise Not_found - | x::right -> - if p x then List.rev_append rev_left right, x - else loop (x :: rev_left) right - in loop [] li - -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 partitioni p = - let rec aux i = function - | [] -> [], [] - | x :: l -> - let (l1, l2) = aux (succ i) l in - if p i x then (x :: l1, l2) - else (l1, x :: l2) - in aux 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_loop f p = function - | [] -> () - | x :: l -> - match f x with - | None -> map_filter_loop f p l - | Some y -> - let c = { head = y; tail = [] } in - p.tail <- cast c; - map_filter_loop f c l - -let map_filter f l = - let c = { head = Obj.magic 0; tail = [] } in - map_filter_loop f c l; - c.tail - -let rec map_filter_i_loop f i p = function - | [] -> () - | x :: l -> - match f i x with - | None -> map_filter_i_loop f (succ i) p l - | Some y -> - let c = { head = y; tail = [] } in - p.tail <- cast c; - map_filter_i_loop f (succ i) c l - -let map_filter_i f l = - let c = { head = Obj.magic 0; tail = [] } in - map_filter_i_loop f 0 c l; - c.tail - -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 n l = - match n, l with - | 0, _ -> 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 deleted file mode 100644 index bc8749b4..00000000 --- a/lib/cList.mli +++ /dev/null @@ -1,239 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 partitioni : (int -> 'a -> bool) -> 'a list -> '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 extend : bool list -> 'a -> 'a list -> 'a list -(** [extend l a [a1..an]] assumes that the number of [true] in [l] is [n]; - it extends [a1..an] by inserting [a] at the position of [false] in [l] *) - val count : ('a -> bool) -> 'a list -> int - - 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 extract_first : ('a -> bool) -> 'a list -> 'a list * 'a - (** Remove and return 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 deleted file mode 100644 index ba0873ff..00000000 --- a/lib/cMap.ml +++ /dev/null @@ -1,218 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> int -end - -module type MonadS = -sig - type +'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -module type S = Map.S - -module type ExtS = -sig - include CSig.MapS - module Set : CSig.SetS with type elt = key - val get : key -> 'a t -> 'a - 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 - val height : 'a t -> int - module Unsafe : - sig - val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t - end - module Monad(M : MonadS) : - sig - val fold : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t - val fold_left : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t - val fold_right : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.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 - val height : 'a map -> int - module Unsafe : - sig - val map : (M.t -> 'a -> M.t * 'b) -> 'a map -> 'b map - end - module Monad(MS : MonadS) : - sig - val fold : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t - val fold_left : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t - val fold_right : (M.t -> 'a -> 'b -> 'b MS.t) -> 'a map -> 'b -> 'b MS.t - 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)) - - let height s = match map_prj s with - | MEmpty -> 0 - | MNode (_, _, _, _, h) -> 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 - - module Monad(M : MonadS) = - struct - - open M - - let rec fold_left f s accu = match map_prj s with - | MEmpty -> return accu - | MNode (l, k, v, r, h) -> - fold_left f l accu >>= fun accu -> - f k v accu >>= fun accu -> - fold_left f r accu - - let rec fold_right f s accu = match map_prj s with - | MEmpty -> return accu - | MNode (l, k, v, r, h) -> - fold_right f r accu >>= fun accu -> - f k v accu >>= fun accu -> - fold_right f l accu - - let fold = fold_left - - end - -end - -module Make(M : Map.OrderedType) = -struct - include Map.Make(M) - include MapExt(M) - let get k m = try find k m with Not_found -> assert false -end diff --git a/lib/cMap.mli b/lib/cMap.mli deleted file mode 100644 index 2838b374..00000000 --- a/lib/cMap.mli +++ /dev/null @@ -1,88 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> int -end - -module type MonadS = -sig - type +'a t - val return : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -end - -module type S = Map.S - -module type ExtS = -sig - include CSig.MapS - (** The underlying Map library *) - - module Set : CSig.SetS with type elt = key - (** Sets used by the domain function *) - - val get : key -> 'a t -> 'a - (** Same as {!find} but fails an assertion instead of raising [Not_found] *) - - 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. *) - - val height : 'a t -> int - (** An indication of the logarithmic size of a map *) - - 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 - - module Monad(M : MonadS) : - sig - val fold : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t - val fold_left : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t - val fold_right : (key -> 'a -> 'b -> 'b M.t) -> 'a t -> 'b -> 'b M.t - end - (** Fold operators parameterized by any monad. *) - -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 deleted file mode 100644 index 7f3ee185..00000000 --- a/lib/cObj.ml +++ /dev/null @@ -1,203 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* = 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 deleted file mode 100644 index 16933a4a..00000000 --- a/lib/cObj.mli +++ /dev/null @@ -1,59 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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/cProfile.ml b/lib/cProfile.ml new file mode 100644 index 00000000..07a11450 --- /dev/null +++ b/lib/cProfile.ml @@ -0,0 +1,716 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* [] || Flags.profile then begin + let outside = create_record () in + stack := [outside]; + last_alloc := get_alloc (); + init_alloc := !last_alloc; + init_time := get_time (); + outside.tottime <- - !init_time; + outside.owntime <- - !init_time + end + +let ajoute n o = + o.owntime <- o.owntime + n.owntime; + o.tottime <- o.tottime + n.tottime; + ajoute_ownalloc o n.ownalloc; + ajoute_totalloc o n.totalloc; + o.owncount <- o.owncount + n.owncount; + o.intcount <- o.intcount + n.intcount; + o.immcount <- o.immcount + n.immcount + +let ajoute_to_list ((name,n) as e) l = + try ajoute n (List.assoc name l); l + with Not_found -> e::l + +let magic = 1249 + +let merge_profile filename (curr_table, curr_outside, curr_total as new_data) = + let (old_table, old_outside, old_total) = + try + let c = open_in filename in + if input_binary_int c <> magic + then Printf.printf "Incompatible recording file: %s\n" filename; + let old_data = input_value c in + close_in c; + old_data + with Sys_error msg -> + (Printf.printf "Unable to open %s: %s\n" filename msg; + new_data) in + let updated_data = + let updated_table = List.fold_right ajoute_to_list curr_table old_table in + ajoute curr_outside old_outside; + ajoute curr_total old_total; + (updated_table, old_outside, old_total) in + begin + (try + let c = + open_out_gen + [Open_creat;Open_wronly;Open_trunc;Open_binary] 0o644 filename in + output_binary_int c magic; + output_value c updated_data; + close_out c + with Sys_error _ -> Printf.printf "Unable to create recording file"); + updated_data + end + +(************************************************) +(* Compute a rough estimation of time overheads *) + +(* Time and space are not measured in the same way *) + +(* Byte allocation is an exact number and for long runs, the total + number of allocated bytes may exceed the maximum integer capacity + (2^31 on 32-bits architectures); therefore, allocation is measured + by small steps, total allocations are computed by adding elementary + measures and carries are controlled from step to step *) + +(* Unix measure of time is approximate and short delays are often + unperceivable; therefore, total times are measured in one (big) + step to avoid rounding errors and to get the best possible + approximation. + Note: Sys.time is the same as: + Unix.(let x = times () in x.tms_utime +. x.tms_stime) + *) + +(* +---------- start profile for f1 +overheadA| ... + ---------- [1w1] 1st call to get_time for f1 + overheadB| ... + ---------- start f1 + real 1 | ... + ---------- start profile for 1st call to f2 inside f1 + overheadA| ... + ---------- [2w1] 1st call to get_time for 1st f2 + overheadB| ... + ---------- start 1st f2 + real 2 | ... + ---------- end 1st f2 + overheadC| ... + ---------- [2w1] 2nd call to get_time for 1st f2 + overheadD| ... + ---------- end profile for 1st f2 + real 1 | ... + ---------- start profile for 2nd call to f2 inside f1 + overheadA| ... + ---------- [2'w1] 1st call to get_time for 2nd f2 + overheadB| ... + ---------- start 2nd f2 + real 2' | ... + ---------- end 2nd f2 + overheadC| ... + ---------- [2'w2] 2nd call to get_time for 2nd f2 + overheadD| ... + ---------- end profile for f2 + real 1 | ... + ---------- end f1 + overheadC| ... +---------- [1w1'] 2nd call to get_time for f1 +overheadD| ... +---------- end profile for f1 + +When profiling f2, overheadB + overheadC should be subtracted from measure +and overheadA + overheadB + overheadC + overheadD should be subtracted from +the amount for f1 + +Then the relevant overheads are : + + "overheadB + overheadC" to be subtracted to the measure of f as many time as f is called and + + "overheadA + overheadB + overheadC + overheadD" to be subtracted to + the measure of f as many time as f calls a profiled function (itself + included) +*) + +let dummy_last_alloc = ref 0.0 +let dummy_spent_alloc () = + let now = get_alloc () in + let before = !last_alloc in + last_alloc := now; + now -. before +let dummy_f x = x +let dummy_stack = ref [create_record ()] +let dummy_ov = 0 + +let loops = 10000 + +let time_overhead_A_D () = + let e = create_record () in + let before = get_time () in + 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::_ -> + 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 dt = get_time () - 1 in + e.tottime <- dt + dummy_ov; e.owntime <- e.owntime + e.tottime; + ajoute_ownalloc p dw; + ajoute_totalloc p dw; + p.owntime <- p.owntime - e.tottime; + 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 !dummy_stack with [] -> assert false | _::s -> stack := s); + dummy_last_alloc := get_alloc () + done; + let after = get_time () in + let beforeloop = get_time () in + for _i = 1 to loops do () done; + let afterloop = get_time () in + float_of_int ((after - before) - (afterloop - beforeloop)) + /. float_of_int loops + +let time_overhead_B_C () = + let dummy_x = 0 in + let before = get_time () in + 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 CErrors.noncritical e -> assert false + done; + let after = get_time () in + let beforeloop = get_time () in + for _i = 1 to loops do () done; + let afterloop = get_time () in + float_of_int ((after - before) - (afterloop - beforeloop)) + /. float_of_int loops + +let compute_alloc lo = lo /. (float_of_int word_length) + +(************************************************) +(* End a profiling session and print the result *) + +let format_profile (table, outside, total) = + print_newline (); + Printf.printf + "%-23s %9s %9s %10s %10s %10s\n" + "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls "; + 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" + name + (float_of_time e.owntime) (float_of_time e.tottime) + (compute_alloc e.ownalloc) + (compute_alloc e.totalloc) + e.owncount e.intcount) + l; + Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f %6d\n" + "others" + (float_of_time outside.owntime) (float_of_time outside.tottime) + (compute_alloc outside.ownalloc) + (compute_alloc outside.totalloc) + outside.intcount; + (* Here, own contains overhead time/alloc *) + Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f\n" + "Est. overhead/total" + (float_of_time total.owntime) (float_of_time total.tottime) + (compute_alloc total.ownalloc) + (compute_alloc total.totalloc); + Printf.printf + "Time in seconds and allocation in words (1 word = %d bytes)\n" + word_length + +let recording_file = ref "" +let set_recording s = recording_file := s + +let adjust_time ov_bc ov_ad e = + let bc_imm = float_of_int e.owncount *. ov_bc in + let ad_imm = float_of_int e.immcount *. ov_ad in + let abcd_all = float_of_int e.intcount *. (ov_ad +. ov_bc) in + {e with + tottime = e.tottime - int_of_float (abcd_all +. bc_imm); + owntime = e.owntime - int_of_float (ad_imm +. bc_imm) } + +let close_profile print = + if !prof_table <> [] then begin + let dw = spent_alloc () in + let t = get_time () in + match !stack with + | [outside] -> + outside.tottime <- outside.tottime + t; + outside.owntime <- outside.owntime + t; + ajoute_ownalloc outside dw; + ajoute_totalloc outside dw; + let ov_bc = time_overhead_B_C () (* B+C overhead *) in + let ov_ad = time_overhead_A_D () (* A+D overhead *) in + let adjust (n,e) = (n, adjust_time ov_bc ov_ad e) in + let adjtable = List.map adjust !prof_table in + let adjoutside = adjust_time ov_bc ov_ad outside in + let totalloc = !last_alloc -. !init_alloc in + let total = create_record () in + total.tottime <- outside.tottime; + total.totalloc <- totalloc; + (* We compute estimations of overhead, put into "own" fields *) + total.owntime <- outside.tottime - adjoutside.tottime; + total.ownalloc <- totalloc -. outside.totalloc; + let current_data = (adjtable, adjoutside, total) in + let updated_data = + match !recording_file with + | "" -> current_data + | name -> merge_profile !recording_file current_data + in + if print then format_profile updated_data; + init_profile () + | _ -> failwith "Inconsistency" + end + +let print_profile () = close_profile true + +let declare_profile name = + if name = "___outside___" || name = "___total___" then + failwith ("Error: "^name^" is a reserved keyword"); + let e = create_record () in + prof_table := (name,e)::!prof_table; + e + +(******************************) +(* Entry points for profiling *) +let profile1 e f a = + 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 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 profile2 e f a b = + 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 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 profile3 e f a b c = + 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 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 profile4 e f a b c d = + 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 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 profile5 e f a b c d g = + 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 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 profile6 e f a b c d g h = + 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 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 profile7 e f a b c d g h i = + 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 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 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) = 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) = 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/cProfile.mli b/lib/cProfile.mli new file mode 100644 index 00000000..764faf8d --- /dev/null +++ b/lib/cProfile.mli @@ -0,0 +1,121 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* unit + +val print_profile : unit -> unit +val reset_profile : unit -> unit +val init_profile : unit -> unit +val declare_profile : string -> profile_key + +val profile1 : profile_key -> ('a -> 'b) -> 'a -> 'b +val profile2 : profile_key -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c +val profile3 : + profile_key -> ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd +val profile4 : + profile_key -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e +val profile5 : + profile_key -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f +val profile6 : + profile_key -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) + -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g +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 + of ML objects *) + +(** Print logical size (in words) and depth of its argument + This function does not disturb the heap *) +val print_logical_stats : 'a -> unit + +(** Print physical size, logical size (in words) and depth of its argument + This function allocates itself a lot (the same order of magnitude + as the physical size of its argument) *) +val print_stats : 'a -> unit diff --git a/lib/cSet.ml b/lib/cSet.ml deleted file mode 100644 index 037cdc35..00000000 --- a/lib/cSet.ml +++ /dev/null @@ -1,67 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 eq 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 deleted file mode 100644 index 2452bb60..00000000 --- a/lib/cSet.mli +++ /dev/null @@ -1,31 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index 151cfbdc..00000000 --- a/lib/cSig.mli +++ /dev/null @@ -1,82 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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. *) - -module type EmptyS = sig end - -module type MapS = -sig - type key - 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 -end diff --git a/lib/cStack.ml b/lib/cStack.ml deleted file mode 100644 index 4acb2930..00000000 --- a/lib/cStack.ml +++ /dev/null @@ -1,42 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index 8dde1d1a..00000000 --- a/lib/cStack.mli +++ /dev/null @@ -1,56 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 deleted file mode 100644 index 0c2ed2e7..00000000 --- a/lib/cString.ml +++ /dev/null @@ -1,181 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 = - if (n / 10) mod 10 = 1 then "th" - else 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 deleted file mode 100644 index 5292b34d..00000000 --- a/lib/cString.mli +++ /dev/null @@ -1,78 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index 4f60a697..00000000 --- a/lib/cThread.ml +++ /dev/null @@ -1,95 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 really_read_fd_2_oc fd oc len = - let i = ref 0 in - let size = 4096 in - let s = String.create size in - while !i < len do - let len = len - !i in - let r = thread_friendly_read_fd fd s ~off:0 ~len:(min len size) in - if r = 0 then raise End_of_file; - i := !i + r; - output oc s 0 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 desired_size = body_size + Marshal.header_size in - if desired_size <= Sys.max_string_length then begin - let msg = String.create desired_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 - end else begin - (* Workaround for 32 bit systems and data > 16M *) - let name, oc = - Filename.open_temp_file ~mode:[Open_binary] "coq" "marshal" in - try - output oc header 0 Marshal.header_size; - really_read_fd_2_oc fd oc body_size; - close_out oc; - let ic = open_in_bin name in - let data = Marshal.from_channel ic in - close_in ic; - Sys.remove name; - data - with e -> Sys.remove name; raise e - end - with Unix.Unix_error _ | Sys_error _ -> raise End_of_file - diff --git a/lib/cThread.mli b/lib/cThread.mli deleted file mode 100644 index 7302dfb5..00000000 --- a/lib/cThread.mli +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index cb436511..00000000 --- a/lib/cUnix.ml +++ /dev/null @@ -1,139 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - (* 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 deleted file mode 100644 index f03719c3..00000000 --- a/lib/cUnix.mli +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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/cWarnings.ml b/lib/cWarnings.ml index cc2463e2..fda25a0a 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Some !current_loc - | loc -> loc - -let create ~name ~category ?(default=Enabled) pp = - Hashtbl.add warnings name { default; category; status = default }; - add_warning_in_category ~name ~category; - if default <> Disabled then - add_warning_in_category ~name ~category:"default"; - fun ?loc x -> let w = Hashtbl.find warnings name in - match w.status with - | Disabled -> () - | AsError -> - begin match refine_loc loc with - | Some loc -> CErrors.user_err_loc (loc,"_",pp x) - | None -> CErrors.errorlabstrm "_" (pp x) - end - | Enabled -> - let msg = - pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ - str category ++ str "]" - in - let loc = refine_loc loc in - Feedback.msg_warning ?loc msg - -let warn_unknown_warning = - create ~name:"unknown-warning" ~category:"toplevel" - (fun name -> strbrk "Unknown warning name: " ++ str name) - let set_warning_status ~name status = try let w = Hashtbl.find warnings name in @@ -82,7 +52,7 @@ let set_all_warnings_status status = let set_category_status ~name status = let names = Hashtbl.find categories name in - List.iter (fun name -> set_warning_status name status) names + List.iter (fun name -> set_warning_status ~name status) names let is_all_keyword name = CString.equal name "all" let is_none_keyword s = CString.equal s "none" @@ -93,7 +63,7 @@ let parse_flag s = | '+' -> (AsError, String.sub s 1 (String.length s - 1)) | '-' -> (Disabled, String.sub s 1 (String.length s - 1)) | _ -> (Enabled, s) - else CErrors.error "Invalid warnings flag" + else CErrors.user_err Pp.(str "Invalid warnings flag") let string_of_flag (status,name) = match status with @@ -118,18 +88,16 @@ let set_status ~name status = let split_flags s = let reg = Str.regexp "[ ,]+" in Str.split reg s -let check_warning ~silent (_status,name) = - is_all_keyword name || - Hashtbl.mem categories name || - Hashtbl.mem warnings name || - (if not silent then warn_unknown_warning name; false) - (** [cut_before_all_rev] removes all flags subsumed by a later occurrence of the "all" flag, and reverses the list. *) let rec cut_before_all_rev acc = function | [] -> acc - | (_status,name as w) :: warnings -> - cut_before_all_rev (w :: if is_all_keyword name then [] else acc) warnings + | (status,name as w) :: warnings -> + let acc = + if is_all_keyword name then [w] + else if is_none_keyword name then [(Disabled,"all")] + else w :: acc in + cut_before_all_rev acc warnings let cut_before_all_rev warnings = cut_before_all_rev [] warnings @@ -150,10 +118,9 @@ let uniquize_flags_rev flags = | [] -> acc in aux [] CString.Set.empty flags -(** [normalize_flags] removes unknown or redundant warnings. If [silent] is - true, it emits a warning when an unknown warning is met. *) +(** [normalize_flags] removes redundant warnings. Unknown warnings are kept + because they may be declared in a plugin that will be linked later. *) let normalize_flags ~silent warnings = - let warnings = List.filter (check_warning ~silent) warnings in let warnings = cut_before_all_rev warnings in uniquize_flags_rev warnings @@ -166,7 +133,7 @@ let normalize_flags_string s = let flags = normalize_flags ~silent:false flags in string_of_flags flags -let rec parse_warnings items = +let parse_warnings items = CList.iter (fun (status, name) -> set_status ~name status) items (* For compatibility, we accept "none" *) @@ -186,3 +153,26 @@ let parse_flags s = let set_flags s = reset_default_warnings (); let s = parse_flags s in flags := s + +(* Adds a warning to the [warnings] and [category] tables. We then reparse the + warning flags string, because the warning being created might have been set + already. *) +let create ~name ~category ?(default=Enabled) pp = + Hashtbl.replace warnings name { default; category; status = default }; + add_warning_in_category ~name ~category; + if default <> Disabled then + add_warning_in_category ~name ~category:"default"; + (* We re-parse and also re-normalize the flags, because the category of the + new warning is now known. *) + set_flags !flags; + fun ?loc x -> + let w = Hashtbl.find warnings name in + match w.status with + | Disabled -> () + | AsError -> CErrors.user_err ?loc (pp x) + | Enabled -> + let msg = + pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ + str category ++ str "]" + in + Feedback.msg_warning ?loc msg diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli index 3f6cee31..f97a53c4 100644 --- a/lib/cWarnings.mli +++ b/lib/cWarnings.mli @@ -1,17 +1,17 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit - val create : name:string -> category:string -> ?default:status -> - ('a -> Pp.std_ppcmds) -> ?loc:Loc.t -> 'a -> unit + ('a -> Pp.t) -> ?loc:Loc.t -> 'a -> unit val get_flags : unit -> string val set_flags : string -> unit diff --git a/lib/canary.ml b/lib/canary.ml deleted file mode 100644 index c01bc158..00000000 --- a/lib/canary.ml +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* M.t - val inj : M.t -> t -end -(** Adds a canary to any type. *) diff --git a/lib/clib.mllib b/lib/clib.mllib deleted file mode 100644 index 1e33173e..00000000 --- a/lib/clib.mllib +++ /dev/null @@ -1,37 +0,0 @@ -Coq_config - -Terminal -Canary -Hook -Hashset -Hashcons -CSet -CMap -Int -Dyn -HMap -Option -Store -Exninfo -Backtrace -IStream -Pp_control -Flags -Control -Loc -CList -CString -Deque -CObj -CArray -CStack -Util -Stateid -Pp -Ppstyle -Richpp -Feedback -CUnix -Envars -Aux_file -Monad diff --git a/lib/control.ml b/lib/control.ml index bf0e1b1c..3fbeb168 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* true - | _ -> false) +let enable_thread_delay = ref 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 + if !enable_thread_delay && !steps = 1000 then begin Thread.delay 0.001; steps := 0; end (** This function does not work on windows, sigh... *) -let unix_timeout n f e = +let unix_timeout n f x e = let timeout_handler _ = raise e in let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in let _ = Unix.alarm n in @@ -35,7 +34,7 @@ let unix_timeout n f e = Sys.set_signal Sys.sigalrm psh in try - let res = f () in + let res = f x in restore_timeout (); res with e -> @@ -43,12 +42,12 @@ let unix_timeout n f e = restore_timeout (); Exninfo.iraise e -let windows_timeout n f e = +let windows_timeout n f x e = let killed = ref false in let exited = ref false in let thread init = while not !killed do - let cur = Unix.time () in + let cur = Unix.gettimeofday () in if float_of_int n <= cur -. init then begin interrupt := true; exited := true; @@ -57,12 +56,12 @@ let windows_timeout n f e = Thread.delay 0.5 done in - let init = Unix.time () in + let init = Unix.gettimeofday () in let _id = Thread.create thread init in try - let res = f () in + let res = f x in let () = killed := true in - let cur = Unix.time () in + let cur = Unix.gettimeofday () in (** The thread did not interrupt, but the computation took longer than expected. *) let () = if float_of_int n <= cur -. init then begin @@ -80,12 +79,13 @@ let windows_timeout n f e = let e = Backtrace.add_backtrace e in Exninfo.iraise e -type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a } +type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } let timeout_fun = match Sys.os_type with -| "Unix" | "Cygwin" -> ref { timeout = unix_timeout } -| _ -> ref { timeout = windows_timeout } +| "Unix" | "Cygwin" -> { timeout = unix_timeout } +| _ -> { timeout = windows_timeout } -let set_timeout f = timeout_fun := f +let timeout_fun_ref = ref timeout_fun +let set_timeout f = timeout_fun_ref := f -let timeout n f e = !timeout_fun.timeout n f e +let timeout n f e = !timeout_fun_ref.timeout n f e diff --git a/lib/control.mli b/lib/control.mli index 681df313..59e2a151 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -1,13 +1,18 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 timeout : int -> ('a -> 'b) -> 'a -> exn -> 'b +(** [timeout n f x e] tries to compute [f x], and if it fails to do so + before [n] seconds, it raises [e] instead. *) +(** Set a particular timeout function; warning, this is an internal + API and it is scheduled to go away. *) +type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } val set_timeout : timeout -> unit -(** Set a particular timeout function. *) diff --git a/lib/coqProject_file.ml4 b/lib/coqProject_file.ml4 new file mode 100644 index 00000000..d6c340f6 --- /dev/null +++ b/lib/coqProject_file.ml4 @@ -0,0 +1,255 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* ] -> "" + | [< 'c; s >] -> (String.make 1 c)^(parse_string s) + | [< >] -> "" +and parse_string2 = parser + | [< ''"' >] -> "" + | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) + | [< >] -> raise (Parsing_error "unterminated string") +and parse_skip_comment = parser + | [< ''\n'; s >] -> s + | [< 'c; s >] -> parse_skip_comment s + | [< >] -> [< >] +and parse_args = parser + | [< '' ' | '\n' | '\t'; s >] -> parse_args s + | [< ''#'; s >] -> parse_args (parse_skip_comment s) + | [< ''"'; str = parse_string2; s >] -> ("" ^ str) :: parse_args s + | [< 'c; str = parse_string; s >] -> ((String.make 1 c) ^ str) :: (parse_args s) + | [< >] -> [] + +let parse f = + let c = open_in f in + let res = parse_args (Stream.of_channel c) in + close_in c; + res +;; + +(* Copy from minisys.ml, since we don't see that file here *) +let exists_dir dir = + let rec strip_trailing_slash dir = + let len = String.length dir in + if len > 0 && (dir.[len-1] = '/' || dir.[len-1] = '\\') + then strip_trailing_slash (String.sub dir 0 (len-1)) else dir in + try Sys.is_directory (strip_trailing_slash dir) with Sys_error _ -> false + + +let process_cmd_line orig_dir proj args = + let parsing_project_file = ref (proj.project_file <> None) in + let sourced x = { thing = x; source = if !parsing_project_file then ProjectFile else CmdLine } in + let orig_dir = (* avoids turning foo.v in ./foo.v *) + if orig_dir = "." then "" else orig_dir in + let error s = Format.eprintf "@[%a]@@\n%!" Pp.pp_with Pp.(str (s^".")); exit 1 in + let mk_path d = + let p = CUnix.correct_path d orig_dir in + { path = CUnix.remove_path_dot (post_canonize p); + canonical_path = CUnix.canonical_path_name p } in + let rec aux proj = function + | [] -> proj + | "-impredicative-set" :: _ -> + error "Use \"-arg -impredicative-set\" instead of \"-impredicative-set\"" + | "-no-install" :: _ -> + error "Use \"-install none\" instead of \"-no-install\"" + | "-custom" :: _ -> + error "Use \"-extra[-phony] target deps command\" instead of \"-custom command deps target\"" + + | ("-no-opt"|"-byte") :: r -> aux { proj with use_ocamlopt = false } r + | ("-full"|"-opt") :: r -> aux { proj with use_ocamlopt = true } r + | "-install" :: d :: r -> + if proj.install_kind <> None then + Feedback.msg_warning (Pp.str "-install set more than once."); + let install = match d with + | "user" -> UserInstall + | "none" -> NoInstall + | "global" -> TraditionalInstall + | _ -> error ("invalid option \""^d^"\" passed to -install") in + aux { proj with install_kind = Some install } r + | "-extra" :: target :: dependencies :: command :: r -> + let tgt = { target; dependencies; phony = false; command } in + aux { proj with extra_targets = proj.extra_targets @ [sourced tgt] } r + | "-extra-phony" :: target :: dependencies :: command :: r -> + let tgt = { target; dependencies; phony = true; command } in + aux { proj with extra_targets = proj.extra_targets @ [sourced tgt] } r + + | "-Q" :: d :: lp :: r -> + aux { proj with q_includes = proj.q_includes @ [sourced (mk_path d,lp)] } r + | "-I" :: d :: r -> + aux { proj with ml_includes = proj.ml_includes @ [sourced (mk_path d)] } r + | "-R" :: d :: lp :: r -> + aux { proj with r_includes = proj.r_includes @ [sourced (mk_path d,lp)] } r + + | "-f" :: file :: r -> + if !parsing_project_file then + raise (Parsing_error ("Invalid option -f in project file " ^ Option.get proj.project_file)); + let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in + let () = match proj.project_file with + | None -> () + | Some _ -> Feedback.msg_warning (Pp.str + "Multiple project files are deprecated.") + in + parsing_project_file := true; + let proj = aux { proj with project_file = Some file } (parse file) in + parsing_project_file := false; + aux proj r + + | "-o" :: file :: r -> + if !parsing_project_file then + raise (Parsing_error ("Invalid option -o in project file " ^ Option.get proj.project_file)); + if String.contains file '/' then + error "Output file must be in the current directory"; + if proj.makefile <> None then + error "Option -o given more than once"; + aux { proj with makefile = Some file } r + | v :: "=" :: def :: r -> + aux { proj with defs = proj.defs @ [sourced (v,def)] } r + | "-arg" :: a :: r -> + aux { proj with extra_args = proj.extra_args @ [sourced a] } r + | f :: r -> + let f = CUnix.correct_path f orig_dir in + let proj = + if exists_dir f then { proj with subdirs = proj.subdirs @ [sourced f] } + else match CUnix.get_extension f with + | ".v" -> + { proj with v_files = proj.v_files @ [sourced f] } + | ".ml" -> { proj with ml_files = proj.ml_files @ [sourced f] } + | ".ml4" -> { proj with ml4_files = proj.ml4_files @ [sourced f] } + | ".mli" -> { proj with mli_files = proj.mli_files @ [sourced f] } + | ".mllib" -> { proj with mllib_files = proj.mllib_files @ [sourced f] } + | ".mlpack" -> { proj with mlpack_files = proj.mlpack_files @ [sourced f] } + | _ -> raise (Parsing_error ("Unknown option "^f)) in + aux proj r + in + aux proj args + + (******************************* API ************************************) + +let cmdline_args_to_project ~curdir args = + process_cmd_line curdir (mk_project None None None true) args + +let read_project_file f = + process_cmd_line (Filename.dirname f) + (mk_project (Some f) None (Some NoInstall) true) (parse f) + +let rec find_project_file ~from ~projfile_name = + let fname = Filename.concat from projfile_name in + if Sys.file_exists fname then Some fname + else + let newdir = Filename.dirname from in + if newdir = from then None + else find_project_file ~from:newdir ~projfile_name +;; + +let all_files { v_files; ml_files; mli_files; ml4_files; + mllib_files; mlpack_files } = + v_files @ mli_files @ ml4_files @ ml_files @ mllib_files @ mlpack_files + +let map_sourced_list f l = List.map (fun x -> f x.thing) l +;; + +let map_cmdline f l = CList.map_filter (function + | {thing=x; source=CmdLine} -> Some (f x) + | {source=ProjectFile} -> None) l + +let coqtop_args_from_project + { ml_includes; r_includes; q_includes; extra_args } += + let map = map_sourced_list in + let args = + map (fun { canonical_path = i } -> ["-I"; i]) ml_includes @ + map (fun ({ canonical_path = i }, l) -> ["-Q"; i; l]) q_includes @ + map (fun ({ canonical_path = p }, l) -> ["-R"; p; l]) r_includes @ + [map (fun x -> x) extra_args] in + List.flatten args +;; + +let filter_cmdline l = CList.map_filter + (function {thing; source=CmdLine} -> Some thing | {source=ProjectFile} -> None) + l +;; + +let forget_source {thing} = thing + +(* vim:set ft=ocaml: *) diff --git a/lib/coqProject_file.mli b/lib/coqProject_file.mli new file mode 100644 index 00000000..5780bb5d --- /dev/null +++ b/lib/coqProject_file.mli @@ -0,0 +1,68 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* string list -> project +val read_project_file : string -> project +val coqtop_args_from_project : project -> string list +val find_project_file : from:string -> projfile_name:string -> string option + +val all_files : project -> string sourced list + +val map_sourced_list : ('a -> 'b) -> 'a sourced list -> 'b list + +(** Only uses the elements with source=CmdLine *) +val map_cmdline : ('a -> 'b) -> 'a sourced list -> 'b list + +(** Only uses the elements with source=CmdLine *) +val filter_cmdline : 'a sourced list -> 'a list + +val forget_source : 'a sourced -> 'a diff --git a/lib/dAst.ml b/lib/dAst.ml new file mode 100644 index 00000000..f34ab956 --- /dev/null +++ b/lib/dAst.ml @@ -0,0 +1,43 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* ('a, 'b) thunk +| Thunk : 'a Lazy.t -> ('a, [ `thunk ]) thunk + +type ('a, 'b) t = ('a, 'b) thunk CAst.t + +let map_thunk (type s) f : (_, s) thunk -> (_, s) thunk = function +| Value x -> Value (f x) +| Thunk k -> Thunk (lazy (f (Lazy.force k))) + +let get_thunk (type s) : ('a, s) thunk -> 'a = function +| Value x -> x +| Thunk k -> Lazy.force k + +let get x = get_thunk x.v + +let make ?loc v = CAst.make ?loc (Value v) + +let delay ?loc v = CAst.make ?loc (Thunk (Lazy.from_fun v)) + +let map f n = CAst.map (fun x -> map_thunk f x) n + +let map_with_loc f n = + CAst.map_with_loc (fun ?loc x -> map_thunk (fun x -> f ?loc x) x) n + +let map_from_loc f (loc, x) = + make ?loc (f ?loc x) + +let with_val f n = f (get n) + +let with_loc_val f n = f ?loc:n.CAst.loc (get n) diff --git a/lib/dAst.mli b/lib/dAst.mli new file mode 100644 index 00000000..28c78784 --- /dev/null +++ b/lib/dAst.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* ('a, 'b) thunk +| Thunk : 'a Lazy.t -> ('a, [ `thunk ]) thunk + +type ('a, 'b) t = ('a, 'b) thunk CAst.t + +val get : ('a, 'b) t -> 'a +val get_thunk : ('a, 'b) thunk -> 'a + +val make : ?loc:Loc.t -> 'a -> ('a, 'b) t +val delay : ?loc:Loc.t -> (unit -> 'a) -> ('a, [ `thunk ]) t + +val map : ('a -> 'b) -> ('a, 'c) t -> ('b, 'c) t +val map_with_loc : (?loc:Loc.t -> 'a -> 'b) -> ('a, 'c) t -> ('b, 'c) t +val map_from_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a Loc.located -> ('b, 'c) t + +val with_val : ('a -> 'b) -> ('a, 'c) t -> 'b +val with_loc_val : (?loc:Loc.t -> 'a -> 'b) -> ('a, 'c) t -> 'b diff --git a/lib/deque.ml b/lib/deque.ml deleted file mode 100644 index ac89a35b..00000000 --- a/lib/deque.ml +++ /dev/null @@ -1,97 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - 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 deleted file mode 100644 index 6963f1db..00000000 --- a/lib/deque.mli +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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/doc.tex b/lib/doc.tex deleted file mode 100644 index 35bd15fa..00000000 --- a/lib/doc.tex +++ /dev/null @@ -1,7 +0,0 @@ - -\newpage -\section*{Utility libraries} - -\ocwsection \label{lib} -This chapter describes the various utility libraries used in the code -of \Coq. diff --git a/lib/dyn.ml b/lib/dyn.ml deleted file mode 100644 index 65d1442a..00000000 --- a/lib/dyn.ml +++ /dev/null @@ -1,148 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - -val create : string -> 'a tag -val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option -val repr : 'a tag -> string - -type any = Any : 'a tag -> any - -val name : string -> any option - -module Map(M : TParam) : -sig - type t - val empty : t - val add : 'a tag -> 'a M.t -> t -> t - val remove : 'a tag -> t -> t - val find : 'a tag -> t -> 'a M.t - val mem : 'a tag -> t -> bool - - type any = Any : 'a tag * 'a M.t -> any - - type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } - val map : map -> t -> t - - val iter : (any -> unit) -> t -> unit - val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r - -end - -val dump : unit -> (int * string) list - -end - -module type S = -sig - include PreS - - module Easy : sig - val make_dyn : string -> ('a -> t) * (t -> 'a) - val inj : 'a -> 'a tag -> t - val prj : t -> 'a tag -> 'a option - end - -end - -module Make(M : CSig.EmptyS) = struct -module Self : PreS = struct -(* Dynamics, programmed with DANGER !!! *) - -type 'a tag = int - -type t = Dyn : 'a tag * 'a -> t - -type any = Any : 'a tag -> any - -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 : string) = - let hash = Hashtbl.hash s in - let () = - if Int.Map.mem hash !dyntab then - let old = Int.Map.find hash !dyntab in - let () = Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old in - assert false - in - let () = dyntab := Int.Map.add hash s !dyntab in - hash - -let eq : 'a 'b. 'a tag -> 'b tag -> ('a, 'b) CSig.eq option = - fun h1 h2 -> if Int.equal h1 h2 then Some (Obj.magic CSig.Refl) else None - -let repr s = - try Int.Map.find s !dyntab - with Not_found -> - let () = Printf.eprintf "Unknown dynamic tag %i\n%!" s in - assert false - -let name s = - let hash = Hashtbl.hash s in - if Int.Map.mem hash !dyntab then Some (Any hash) else None - -let dump () = Int.Map.bindings !dyntab - -module Map(M : TParam) = -struct -type t = Obj.t M.t Int.Map.t -let cast : 'a M.t -> 'b M.t = Obj.magic -let empty = Int.Map.empty -let add tag v m = Int.Map.add tag (cast v) m -let remove tag m = Int.Map.remove tag m -let find tag m = cast (Int.Map.find tag m) -let mem = Int.Map.mem - -type any = Any : 'a tag * 'a M.t -> any - -type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } -let map f m = Int.Map.mapi f.map m - -let iter f m = Int.Map.iter (fun k v -> f (Any (k, v))) m -let fold f m accu = Int.Map.fold (fun k v accu -> f (Any (k, v)) accu) m accu -end - -end -include Self - -module Easy = struct -(* now tags are opaque, we can do the trick *) -let make_dyn (s : string) = - (fun (type a) (tag : a tag) -> - let infun : (a -> t) = fun x -> Dyn (tag, x) in - let outfun : (t -> a) = fun (Dyn (t, x)) -> - match eq tag t with - | None -> assert false - | Some CSig.Refl -> x - in - (infun, outfun)) - (create s) - -let inj x tag = Dyn(tag,x) -let prj : type a. t -> a tag -> a option = - fun (Dyn(tag',x)) tag -> - match eq tag tag' with - | None -> None - | Some CSig.Refl -> Some x -end - -end - diff --git a/lib/dyn.mli b/lib/dyn.mli deleted file mode 100644 index 448b11a1..00000000 --- a/lib/dyn.mli +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - -val create : string -> 'a tag -val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option -val repr : 'a tag -> string - -type any = Any : 'a tag -> any - -val name : string -> any option - -module Map(M : TParam) : -sig - type t - val empty : t - val add : 'a tag -> 'a M.t -> t -> t - val remove : 'a tag -> t -> t - val find : 'a tag -> t -> 'a M.t - val mem : 'a tag -> t -> bool - - type any = Any : 'a tag * 'a M.t -> any - - type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } - val map : map -> t -> t - - val iter : (any -> unit) -> t -> unit - val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r - -end - -val dump : unit -> (int * string) list - -module Easy : sig - - (* To create a dynamic type on the fly *) - val make_dyn : string -> ('a -> t) * (t -> 'a) - - (* For types declared with the [create] function above *) - val inj : 'a -> 'a tag -> t - val prj : t -> 'a tag -> 'a option -end - -end - -(** FIXME: use OCaml 4.02 generative functors when available *) -module Make(M : CSig.EmptyS) : S diff --git a/lib/envars.ml b/lib/envars.ml index 89ce5283..be82bfe9 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [] | Some x -> [x] - let home ~warn = getenv_else "HOME" (fun () -> try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> @@ -81,9 +81,6 @@ let expand_path_macros ~warn s = (** {2 Coq paths} *) -let relative_base = - Filename.dirname (Filename.dirname Sys.executable_name) - let coqbin = CUnix.canonical_path_name (Filename.dirname Sys.executable_name) @@ -98,25 +95,26 @@ let _ = if Coq_config.arch_is_win32 then Unix.putenv "PATH" (coqbin ^ ";" ^ getenv_else "PATH" (fun () -> "")) +(** Add a local installation suffix (unless the suffix is itself + absolute in which case the prefix does not matter) *) +let use_suffix prefix suffix = + if String.length suffix > 0 && suffix.[0] = '/' then suffix else prefix / suffix + (** [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]. + the installation directory [dir] given relatively to [coqroot], + which maybe has been relocated. If the check fails, then [oth ()] is evaluated. Using file system equality seems well enough for this heuristic *) let check_file_else ~dir ~file oth = - let path = if Coq_config.local then coqroot else coqroot / dir in + let path = use_suffix 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 + check_file_else ~dir:Coq_config.coqlibsuffix ~file:prelude (fun () -> - let coqlib = match Coq_config.coqlib with - | Some coqlib -> coqlib - | None -> coqroot - in - if Sys.file_exists (coqlib / prelude) then coqlib + if not Coq_config.local && Sys.file_exists (Coq_config.coqlib / prelude) + then Coq_config.coqlib else fail "cannot guess a path for Coq libraries; please use -coqlib option") @@ -130,8 +128,19 @@ let set_coqlib ~fail = let coqlib () = !Flags.coqlib 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) + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.docdirsuffix in + if Sys.file_exists path then path else Coq_config.docdir + +let datadir () = + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.datadirsuffix in + if Sys.file_exists path then path else Coq_config.datadir + +let configdir () = + (* This assumes implicitly that the suffix is non-trivial *) + let path = use_suffix coqroot Coq_config.configdirsuffix in + if Sys.file_exists path then path else Coq_config.configdir let coqpath = let coqpath = getenv_else "COQPATH" (fun () -> "") in @@ -146,31 +155,23 @@ let coqpath = let exe s = s ^ Coq_config.exec_extension -let guess_ocamlfind () = which (user_path ()) (exe "ocamlfind") - -let ocamlfind () = - if !Flags.ocamlfind_spec then !Flags.ocamlfind else - if !Flags.boot then Coq_config.ocamlfind else - try guess_ocamlfind () / "ocamlfind" with Not_found -> Coq_config.ocamlfind - -(** {2 Camlp4 paths} *) +let ocamlfind () = Coq_config.ocamlfind -let guess_camlp4bin () = which (user_path ()) (exe Coq_config.camlp4) +(** {2 Camlp5 paths} *) -let camlp4bin () = - if !Flags.camlp4bin_spec then !Flags.camlp4bin else - if !Flags.boot then Coq_config.camlp4bin else - try guess_camlp4bin () - with Not_found -> - Coq_config.camlp4bin +let guess_camlp5bin () = which (user_path ()) (exe "camlp5") -let camlp4 () = camlp4bin () / exe Coq_config.camlp4 +let camlp5bin () = + if !Flags.boot then Coq_config.camlp5bin else + try guess_camlp5bin () + with Not_found -> + Coq_config.camlp5bin -let camlp4lib () = +let camlp5lib () = if !Flags.boot then - Coq_config.camlp4lib + Coq_config.camlp5lib else - let ex, res = CUnix.run_command (ocamlfind () ^ " query " ^ Coq_config.camlp4) in + let ex, res = CUnix.run_command (ocamlfind () ^ " query camlp5") in match ex with | Unix.WEXITED 0 -> String.strip res | _ -> "/dev/null" @@ -190,20 +191,27 @@ let xdg_data_dirs warn = 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"] + | Not_found -> [datadir ()] 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 + xdg_data_home warn :: sys_dirs let xdg_dirs ~warn = List.filter Sys.file_exists (xdg_data_dirs warn) + +(* Print the configuration information *) + +let print_config ?(prefix_var_name="") f coq_src_subdirs = + let open Printf in + fprintf f "%sLOCAL=%s\n" prefix_var_name (if Coq_config.local then "1" else "0"); + fprintf f "%sCOQLIB=%s/\n" prefix_var_name (coqlib ()); + fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); + fprintf f "%sOCAMLFIND=%s\n" prefix_var_name (ocamlfind ()); + fprintf f "%sCAMLP5O=%s\n" prefix_var_name Coq_config.camlp5o; + fprintf f "%sCAMLP5BIN=%s/\n" prefix_var_name (camlp5bin ()); + fprintf f "%sCAMLP5LIB=%s\n" prefix_var_name (camlp5lib ()); + fprintf f "%sCAMLP5OPTIONS=%s\n" prefix_var_name Coq_config.camlp5compat; + fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; + fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name + (if Coq_config.has_natdynlink then "true" else "false"); + fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs) + diff --git a/lib/envars.mli b/lib/envars.mli index 90a42859..66b86252 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit) -> string (** [coqlib] is the path to the Coq library. *) val coqlib : unit -> string +(** [docdir] is the path to the installed documentation. *) +val docdir : unit -> string + +(** [datadir] is the path to the installed data directory. *) +val datadir : unit -> string + +(** [configdir] is the path to the installed config directory. *) +val configdir : 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 @@ -47,17 +55,14 @@ val coqroot : string the order it gets added to the search path. *) val coqpath : string list -(** [camlbin ()] is the path to the ocamlfind binary. *) +(** [camlfind ()] is the path to the ocamlfind binary. *) val ocamlfind : unit -> string -(** [camlp4bin ()] is the path to the camlp4 binary. *) -val camlp4bin : unit -> string +(** [camlp5bin ()] is the path to the camlp5 binary. *) +val camlp5bin : unit -> string -(** [camlp4lib ()] is the path to the camlp4 library. *) -val camlp4lib : unit -> string - -(** [camlp4 ()] is the camlp4 utility. *) -val camlp4 : unit -> string +(** [camlp5lib ()] is the path to the camlp5 library. *) +val camlp5lib : unit -> string (** Coq tries to honor the XDG Base Directory Specification to access the user's configuration files. @@ -66,6 +71,8 @@ val camlp4 : unit -> string *) 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 + +(** {6 Prints the configuration information } *) +val print_config : ?prefix_var_name:string -> out_channel -> string list -> unit diff --git a/lib/exninfo.ml b/lib/exninfo.ml deleted file mode 100644 index d049dc6c..00000000 --- a/lib/exninfo.ml +++ /dev/null @@ -1,104 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 aa7bddf2..4dc48ab6 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* state list val success : state -> bool - val pp : state -> std_ppcmds + val pp : state -> Pp.t end module Make = functor(S : SearchProblem) -> struct diff --git a/lib/explore.mli b/lib/explore.mli index 2b273e12..528a1b97 100644 --- a/lib/explore.mli +++ b/lib/explore.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool - val pp : state -> Pp.std_ppcmds + val pp : state -> Pp.t end diff --git a/lib/feedback.ml b/lib/feedback.ml index 44b3ee35..cb8f8aad 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* level -> std_ppcmds -> unit - -let msgnl_with ?pp_tag fmt strm = msg_with ?pp_tag fmt (strm ++ fnl ()) - -(* XXX: This is really painful! *) -module Emacs = struct - - (* 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_err g = - hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) - - let emacs_quote_info_start = "" - let emacs_quote_info_end = "" - - let emacs_quote_info g = - hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) - -end - -open Emacs - -let dbg_str = tag Ppstyle.(Tag.inj debug_tag tag) (str "Debug:") ++ spc () -let info_str = mt () -let warn_str = tag Ppstyle.(Tag.inj warning_tag tag) (str "Warning:") ++ spc () -let err_str = tag Ppstyle.(Tag.inj error_tag tag) (str "Error:" ) ++ spc () - -let make_body quoter info ?loc s = - let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in - quoter (hov 0 (loc ++ info ++ s)) - -(* Generic logger *) -let gen_logger dbg err ?pp_tag ?loc level msg = match level with - | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) - | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) - | Notice -> msgnl_with ?pp_tag !std_ft msg - | Warning -> Flags.if_warn (fun () -> - msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) - -(* We provide a generic clear_log_backend callback for backends - wanting to do clenaup after the print. -*) -let std_logger_tag = ref None -let std_logger_cleanup = ref (fun () -> ()) - -let std_logger ?loc level msg = - gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; - !std_logger_cleanup () - -(* Rules for emacs: - - Debug/info: emacs_quote_info - - Warning/Error: emacs_quote_err - - Notice: unquoted - - Note the inconsistency. - *) -let emacs_logger = gen_logger emacs_quote_info emacs_quote_err ?pp_tag:None - -(** Color logging. Moved from pp_style, it may need some more refactoring *) - -(** Not thread-safe. We should put a lock somewhere if we print from - different threads. Do we? *) -let make_style_stack () = - (** Default tag is to reset everything *) - let empty = Terminal.make () in - let default_tag = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; - }) - in - let style_stack = ref [] in - let peek () = match !style_stack with - | [] -> default_tag (** Anomalous case, but for robustness *) - | st :: _ -> st - in - let push tag = - let style = match Ppstyle.get_style tag with - | None -> empty - | Some st -> st - in - (** Use the merging of the latest tag and the one being currently pushed. - This may be useful if for instance the latest tag changes the background and - the current one the foreground, so that the two effects are additioned. *) - let style = Terminal.merge (peek ()) style in - style_stack := style :: !style_stack; - Terminal.eval style - in - let pop _ = match !style_stack with - | [] -> (** Something went wrong, we fallback *) - Terminal.eval default_tag - | _ :: rem -> style_stack := rem; - Terminal.eval (peek ()) - in - let clear () = style_stack := [] in - push, pop, clear - -let init_color_output () = - let open Pp_control in - let push_tag, pop_tag, clear_tag = make_style_stack () in - std_logger_cleanup := clear_tag; - std_logger_tag := Some Ppstyle.pp_tag; - let tag_handler = { - Format.mark_open_tag = push_tag; - Format.mark_close_tag = pop_tag; - Format.print_open_tag = ignore; - Format.print_close_tag = ignore; - } in - Format.pp_set_mark_tags !std_ft true; - Format.pp_set_mark_tags !err_ft true; - Format.pp_set_formatter_tag_functions !std_ft tag_handler; - Format.pp_set_formatter_tag_functions !err_ft tag_handler - -let logger = ref std_logger -let set_logger l = logger := l - -let msg_info ?loc x = !logger ?loc Info x -let msg_notice ?loc x = !logger ?loc Notice x -let msg_warning ?loc x = !logger ?loc Warning x -let msg_error ?loc x = !logger ?loc Error x -let msg_debug ?loc x = !logger ?loc Debug x - (** Feeders *) -let feeders = ref [] -let add_feeder f = feeders := f :: !feeders +let feeders : (int, feedback -> unit) Hashtbl.t = Hashtbl.create 7 -let debug_feeder = function - | { contents = Message (Debug, loc, pp) } -> - msg_debug ?loc (Pp.str (Richpp.raw_print pp)) - | _ -> () +let add_feeder = + let f_id = ref 0 in fun f -> + incr f_id; + Hashtbl.add feeders !f_id f; + !f_id -let feedback_id = ref (Edit 0) +let del_feeder fid = Hashtbl.remove feeders fid + +let default_route = 0 +let span_id = ref Stateid.dummy +let doc_id = ref 0 let feedback_route = ref default_route -let set_id_for_feedback ?(route=default_route) i = - feedback_id := i; feedback_route := route +let set_id_for_feedback ?(route=default_route) d i = + doc_id := d; + span_id := i; + feedback_route := route -let feedback ?id ?route what = +let warn_no_listeners = ref true +let feedback ?did ?id ?route what = let m = { contents = what; - route = Option.default !feedback_route route; - id = Option.default !feedback_id id; + route = Option.default !feedback_route route; + doc_id = Option.default !doc_id did; + span_id = Option.default !span_id id; } in - List.iter (fun f -> f m) !feeders + if !warn_no_listeners && Hashtbl.length feeders = 0 then + Format.eprintf "Warning, feedback message received but no listener to handle it!@\n%!"; + Hashtbl.iter (fun _ f -> f m) feeders +(* Logging messages *) let feedback_logger ?loc lvl msg = - feedback ~route:!feedback_route ~id:!feedback_id - (Message (lvl, loc, Richpp.richpp_of_pp msg)) - -(* Output to file *) -let ft_logger old_logger ft ?loc level mesg = - let id x = x in - match level with - | Debug -> msgnl_with ft (make_body id dbg_str mesg) - | Info -> msgnl_with ft (make_body id info_str mesg) - | Notice -> msgnl_with ft mesg - | Warning -> old_logger ?loc level mesg - | Error -> old_logger ?loc level mesg - -let with_output_to_file fname func input = - let old_logger = !logger in - let channel = open_out (String.concat "." [fname; "out"]) in - logger := ft_logger old_logger (Format.formatter_of_out_channel channel); - try - let output = func input in - logger := old_logger; - close_out channel; - output - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - logger := old_logger; - close_out channel; - Exninfo.iraise reraise - + feedback ~route:!feedback_route ~id:!span_id (Message (lvl, loc, msg)) + +let msg_info ?loc x = feedback_logger ?loc Info x +let msg_notice ?loc x = feedback_logger ?loc Notice x +let msg_warning ?loc x = feedback_logger ?loc Warning x +let msg_error ?loc x = feedback_logger ?loc Error x +let msg_debug ?loc x = feedback_logger ?loc Debug x + +(* Helper for tools willing to understand only the messages *) +let console_feedback_listener fmt = + let open Format in + let pp_lvl fmt lvl = match lvl with + | Error -> fprintf fmt "Error: " + | Info -> fprintf fmt "Info: " + | Debug -> fprintf fmt "Debug: " + | Warning -> fprintf fmt "Warning: " + | Notice -> fprintf fmt "" + in + let pp_loc fmt loc = let open Loc in match loc with + | None -> fprintf fmt "" + | Some loc -> + let where = + match loc.fname with InFile f -> f | ToplevelInput -> "Toplevel input" in + fprintf fmt "\"%s\", line %d, characters %d-%d:@\n" + where loc.line_nb (loc.bp-loc.bol_pos) (loc.ep-loc.bol_pos) in + let checker_feed (fb : feedback) = + match fb.contents with + | Processed -> () + | Incomplete -> () + | Complete -> () + | ProcessingIn _ -> () + | InProgress _ -> () + | WorkerStatus (_,_) -> () + | AddedAxiom -> () + | GlobRef (_,_,_,_,_) -> () + | GlobDef (_,_,_,_) -> () + | FileDependency (_,_) -> () + | FileLoaded (_,_) -> () + | Custom (_,_,_) -> () + | Message (lvl,loc,msg) -> + fprintf fmt "@[%a@]%a@[%a@]\n%!" pp_loc loc pp_lvl lvl Pp.pp_with msg + in checker_feed diff --git a/lib/feedback.mli b/lib/feedback.mli index 5160bd5b..64fdf372 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -1,14 +1,16 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* level -> Pp.std_ppcmds -> unit - -(** [set_logger l] makes the [msg_*] to use [l] for logging *) -val set_logger : logger -> unit - -(** [std_logger] standard logger to [stdout/stderr] *) -val std_logger : logger +(* The interpreter assignes an state_id to the ast, and feedbacks happening + * during interpretation are attached to it. + *) -(** [init_color_output ()] Enable color in the std_logger *) -val init_color_output : unit -> unit +(** [add_feeder f] adds a feeder listiner [f], returning its id *) +val add_feeder : (feedback -> unit) -> int -(** [feedback_logger] will produce feedback messages instead IO events *) -val feedback_logger : logger -val emacs_logger : logger +(** [del_feeder fid] removes the feeder with id [fid] *) +val del_feeder : int -> unit - -(** [add_feeder] feeders observe the feedback *) -val add_feeder : (feedback -> unit) -> unit - -(** Prints feedback messages of kind Message(Debug,_) using msg_debug *) -val debug_feeder : feedback -> unit - -(** [feedback ?id ?route fb] produces feedback fb, with [route] and - [id] set appropiatedly, if absent, it will use the defaults set by - [set_id_for_feedback] *) -val feedback : - ?id:edit_or_state_id -> ?route:route_id -> feedback_content -> unit +(** [feedback ?did ?sid ?route fb] produces feedback [fb], with + [route] and [did, sid] set appropiatedly, if absent, it will use + the defaults set by [set_id_for_feedback] *) +val feedback : ?did:doc_id -> ?id:Stateid.t -> ?route:route_id -> feedback_content -> unit (** [set_id_for_feedback route id] Set the defaults for feedback *) -val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit - -(** [with_output_to_file file f x] executes [f x] with logging - redirected to a file [file] *) -val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b +val set_id_for_feedback : ?route:route_id -> doc_id -> Stateid.t -> unit (** {6 output functions} @@ -109,24 +84,29 @@ relaxed. *) (* Should we advertise these functions more? Should they be the ONLY allowed way to output something? *) -val msg_info : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_info : ?loc:Loc.t -> Pp.t -> unit (** Message that displays information, usually in verbose mode, such as [Foobar is defined] *) -val msg_notice : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_notice : ?loc:Loc.t -> Pp.t -> unit (** Message that should be displayed, such as [Print Foo] or [Show Bar]. *) -val msg_warning : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_warning : ?loc:Loc.t -> Pp.t -> unit (** Message indicating that something went wrong, but without serious consequences. *) -val msg_error : ?loc:Loc.t -> Pp.std_ppcmds -> unit -(** Message indicating that something went really wrong, though still - recoverable; otherwise an exception would have been raised. *) +val msg_error : ?loc:Loc.t -> Pp.t -> unit +[@@ocaml.deprecated "msg_error is an internal function and should not be \ + used unless you know what you are doing. Use \ + [CErrors.user_err] instead."] -val msg_debug : ?loc:Loc.t -> Pp.std_ppcmds -> unit +val msg_debug : ?loc:Loc.t -> Pp.t -> unit (** For debugging purposes *) +val console_feedback_listener : Format.formatter -> feedback -> unit +(** Helper for tools willing to print to the feedback system *) - - +val warn_no_listeners : bool ref +(** The library will print a warning to the console if no listener is + available by default; ML-clients willing to use Coq without a + feedback handler should set this to false. *) diff --git a/lib/flags.ml b/lib/flags.ml index 0e2f7e5a..8491873e 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -1,18 +1,34 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let reraise = Backtrace.add_backtrace reraise in - let () = o := old in - Exninfo.iraise reraise +(* If [restore] is false, whenever [f] modifies the ref, we will + preserve the modification. *) +let with_modified_ref ?(restore=true) r nf f x = + let old_ref = !r in r := nf !r; + try + let pre = !r in + let res = f x in + (* If r was modified don't restore its old value *) + if restore || pre == !r then r := old_ref; + res + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + r := old_ref; + Exninfo.iraise reraise + +let with_option o f x = with_modified_ref ~restore:false o (fun _ -> true) f x +let without_option o f x = with_modified_ref ~restore:false o (fun _ -> false) f x +let with_extra_values o l f x = with_modified_ref o (fun ol -> ol@l) f x + +(* hide the [restore] option as internal *) +let with_modified_ref r nf f x = with_modified_ref r nf f x let with_options ol f x = let vl = List.map (!) ol in @@ -25,80 +41,25 @@ let with_options ol f x = 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 -> - 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 -type compilation_mode = BuildVo | BuildVio | Vio2Vo -let compilation_mode = ref BuildVo -let compilation_output_name = ref None +let record_aux_file = ref false let test_mode = ref false -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") -type tac_error_filter = [ `None | `Only of string list | `All ] -let async_proofs_tac_error_resilience = ref (`Only [ "curly" ]) -let async_proofs_cmd_error_resilience = ref true - -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 async_proofs_delegation_threshold = ref 0.03 +let async_proofs_is_worker () = !async_proofs_worker_id <> "master" let debug = ref false + let in_debugger = ref false let in_toplevel = ref false let profile = false -let print_emacs = ref false -let coqtop_ui = ref false - -let xml_export = ref false - let ide_slave = ref false -let ideslave_coqtop_flags = ref None - -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 @@ -108,33 +69,25 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current +type compat_version = V8_6 | V8_7 | Current let compat_version = ref Current let version_compare v1 v2 = match v1, v2 with -| V8_2, V8_2 -> 0 -| V8_2, (V8_3 | V8_4 | V8_5 | Current) -> -1 -| V8_3, V8_2 -> 1 -| V8_3, V8_3 -> 0 -| V8_3, (V8_4 | V8_5 | Current) -> -1 -| V8_4, (V8_2 | V8_3) -> 1 -| V8_4, V8_4 -> 0 -| V8_4, (V8_5 | Current) -> -1 -| V8_5, (V8_2 | V8_3 | V8_4) -> 1 -| V8_5, V8_5 -> 0 -| V8_5, Current -> -1 -| Current, Current -> 0 -| Current, (V8_2 | V8_3 | V8_4 | V8_5) -> 1 + | V8_6, V8_6 -> 0 + | V8_6, _ -> -1 + | _, V8_6 -> 1 + | V8_7, V8_7 -> 0 + | V8_7, _ -> -1 + | _, V8_7 -> 1 + | Current, Current -> 0 let version_strictly_greater v = version_compare !compat_version v > 0 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" - | V8_5 -> "8.5" + | V8_6 -> "8.6" + | V8_7 -> "8.7" | Current -> "current" (* Translate *) @@ -142,32 +95,24 @@ let beautify = ref false let beautify_file = ref false (* Silent / Verbose *) -let silent = ref false -let make_silent flag = silent := flag; () -let is_silent () = !silent -let is_verbose () = not !silent +let quiet = ref false +let silently f x = with_option quiet f x +let verbosely f x = without_option quiet f x -let silently f x = with_option silent f x -let verbosely f x = without_option silent f x - -let if_silent f x = if !silent then f x -let if_verbose f x = if not !silent then f x +let if_silent f x = if !quiet then f x +let if_verbose f x = if not !quiet then f x 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 is_auto_intros () = !auto_intros 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 +let polymorphic_inductive_cumulativity = ref false +let make_polymorphic_inductive_cumulativity b = polymorphic_inductive_cumulativity := b +let is_polymorphic_inductive_cumulativity () = !polymorphic_inductive_cumulativity (** [program_mode] tells that Program mode has been activated, either globally via [Set Program] or locally via the Program command prefix. *) @@ -179,12 +124,6 @@ let warn = ref true let make_warn flag = warn := flag; () let if_warn f x = if !warn then f x -(* The number of printed hypothesis in a goal *) - -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 - (* Flags for external tools *) let browser_cmd_fmt = @@ -206,14 +145,6 @@ let is_standard_doc_url url = let coqlib_spec = ref false let coqlib = ref "(not initialized yet)" -(* Options for changing ocamlfind (used by coqmktop) *) -let ocamlfind_spec = ref false -let ocamlfind = ref Coq_config.camlbin - -(* Options for changing camlp4bin (used by coqmktop) *) -let camlp4bin_spec = ref false -let camlp4bin = ref Coq_config.camlp4bin - (* Level of inlining during a functor application *) let default_inline_level = 100 @@ -222,15 +153,18 @@ let set_inline_level = (:=) inline_level let get_inline_level () = !inline_level (* Native code compilation for conversion and normalization *) -let native_compiler = ref false +let output_native_objects = ref false (* 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 let profile_ltac = ref false let profile_ltac_cutoff = ref 2.0 let dump_bytecode = ref false let set_dump_bytecode = (:=) dump_bytecode let get_dump_bytecode () = !dump_bytecode + +let dump_lambda = ref false +let set_dump_lambda = (:=) dump_lambda +let get_dump_lambda () = !dump_lambda diff --git a/lib/flags.mli b/lib/flags.mli index 89760264..85aaf879 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -1,85 +1,70 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 +(** Async-related flags *) 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 -type tac_error_filter = [ `None | `Only of string list | `All ] -val async_proofs_tac_error_resilience : tac_error_filter ref -val async_proofs_cmd_error_resilience : bool ref -val async_proofs_delegation_threshold : float ref +val async_proofs_is_worker : unit -> bool +(** Debug flags *) 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 xml_export : bool ref - +(* -ide_slave: printing will be more verbose, will affect stm caching *) val ide_slave : bool ref -val ideslave_coqtop_flags : string option ref - -val time : bool ref +(* development flag to detect race conditions, it should go away. *) val we_are_parsing : bool ref +(* Set Printing All flag. For some reason it is a global flag *) val raw_print : bool ref -val record_print : bool ref + +(* Univ print flag, never set anywere. Maybe should belong to Univ? *) val univ_print : bool ref -type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current +type compat_version = V8_6 | V8_7 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool val version_less_or_equal : compat_version -> bool val pr_version : compat_version -> string +(* Beautify command line flags, should move to printing? *) val beautify : bool ref val beautify_file : bool ref -val make_silent : bool -> unit -val is_silent : unit -> bool -val is_verbose : unit -> bool +(* Coq quiet mode. Note that normal mode is called "verbose" here, + whereas [quiet] supresses normal output such as goals in coqtop *) +val quiet : bool ref val silently : ('a -> 'b) -> 'a -> 'b val verbosely : ('a -> 'b) -> 'a -> 'b val if_silent : ('a -> unit) -> 'a -> unit val if_verbose : ('a -> unit) -> 'a -> unit +(* Miscellaneus flags for vernac *) val make_auto_intros : bool -> unit val is_auto_intros : unit -> bool @@ -90,14 +75,23 @@ val is_program_mode : unit -> bool 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 +(** Global polymorphic inductive cumulativity flag. *) +val make_polymorphic_inductive_cumulativity : bool -> unit +val is_polymorphic_inductive_cumulativity : unit -> bool val warn : bool ref val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit +(** [with_modified_ref r nf f x] Temporarily modify a reference in the + call to [f x] . Be very careful with these functions, it is very + easy to fall in the typical problem with effects: + + with_modified_ref r nf f x y != with_modified_ref r nf (f x) y + +*) +val with_modified_ref : 'c ref -> ('c -> 'c) -> ('a -> 'b) -> 'a -> 'b + (** 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 @@ -111,10 +105,6 @@ 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 - (** Options for external tools *) (** Returns string format for default browser to use from Coq or CoqIDE *) @@ -126,27 +116,17 @@ val is_standard_doc_url : string -> bool val coqlib_spec : bool ref val coqlib : string ref -(** Options for specifying where OCaml binaries reside *) -val ocamlfind_spec : bool ref -val ocamlfind : string ref -val camlp4bin_spec : bool ref -val camlp4bin : string ref - (** Level of inlining during a functor application *) val set_inline_level : int -> unit val get_inline_level : unit -> int val default_inline_level : int -(** Native code compilation for conversion and normalization *) -val native_compiler : bool ref +(** When producing vo objects, also compile the native-code version *) +val output_native_objects : 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. *) - val profile_ltac : bool ref val profile_ltac_cutoff : float ref @@ -154,3 +134,8 @@ val profile_ltac_cutoff : float ref val dump_bytecode : bool ref val set_dump_bytecode : bool -> unit val get_dump_bytecode : unit -> bool + +(** Dump the VM lambda code after compilation (for debugging purposes) *) +val dump_lambda : bool ref +val set_dump_lambda : bool -> unit +val get_dump_lambda : unit -> bool diff --git a/lib/future.ml b/lib/future.ml index ea0382a6..7a5b6f69 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -1,17 +1,13 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false : unit -> freeze) -let unfreeze = ref (fun _ -> () : freeze -> unit) -let set_freeze f g = freeze := f; unfreeze := g - let not_ready_msg = ref (fun name -> Pp.strbrk("The value you are asking for ("^name^") is not ready yet. "^ "Please wait or pass "^ @@ -30,6 +26,7 @@ let customize_not_here_msg f = not_here_msg := f exception NotReady of string exception NotHere of string + let _ = CErrors.register_handler (function | NotReady name -> !not_ready_msg name | NotHere name -> !not_here_msg name @@ -59,7 +56,7 @@ type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computat and 'a comp = | Delegated of (unit -> unit) | Closure of (unit -> 'a) - | Val of 'a * freeze option + | Val of 'a | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *) and 'a comput = @@ -74,7 +71,7 @@ let create ?(name=unnamed) ?(uuid=UUID.fresh ()) f x = ref (Ongoing (name, CEphemeron.create (uuid, f, Pervasives.ref x))) let get x = match !x with - | Finished v -> unnamed, UUID.invalid, id, ref (Val (v,None)) + | Finished v -> unnamed, UUID.invalid, id, ref (Val v) | Ongoing (name, x) -> try let uuid, fix, c = CEphemeron.get x in name, uuid, fix, c with CEphemeron.InvalidKey -> @@ -95,13 +92,13 @@ let is_exn kx = let _, _, _, x = get kx in match !x with | Val _ | Closure _ | Delegated _ -> false let peek_val kx = let _, _, _, x = get kx in match !x with - | Val (v, _) -> Some v + | 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 from_val ?(fix_exn=id) v = create fix_exn (Val v) +let from_here ?(fix_exn=id) v = create fix_exn (Val v) let fix_exn_of ck = let _, _, fix_exn, _ = get ck in fix_exn @@ -110,7 +107,7 @@ let create_delegate ?(blocking=true) ~name fix_exn = let _, _, fix_exn, c = get ck in assert (match !c with Delegated _ -> true | _ -> false); begin match v with - | `Val v -> c := Val (v, None) + | `Val v -> c := Val v | `Exn e -> c := Exn (fix_exn e) | `Comp f -> let _, _, _, comp = get f in c := !comp end; signal () in @@ -124,17 +121,16 @@ let create_delegate ?(blocking=true) ~name fix_exn = ck, assignement signal ck (* TODO: get rid of try/catch to be stackless *) -let rec compute ~pure ck : 'a value = +let rec compute ck : 'a value = let _, _, fix_exn, c = get ck in match !c with - | Val (x, _) -> `Val x + | Val x -> `Val x | Exn (e, info) -> `Exn (e, info) - | Delegated wait -> wait (); compute ~pure ck + | Delegated wait -> wait (); compute ck | Closure f -> try let data = f () in - let state = if pure then None else Some (!freeze ()) in - c := Val (data, state); `Val data + c := Val data; `Val data with e -> let e = CErrors.push e in let e = fix_exn e in @@ -142,60 +138,30 @@ let rec compute ~pure ck : 'a value = | (NotReady _, _) -> `Exn e | _ -> c := Exn e; `Exn e -let force ~pure x = match compute ~pure x with +let force x = match compute x with | `Val v -> v | `Exn e -> Exninfo.iraise e -let chain ~pure ck f = +let chain ck f = let name, uuid, fix_exn, c = get ck in create ~uuid ~name fix_exn (match !c with - | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck)) + | Closure _ | Delegated _ -> Closure (fun () -> f (force 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 _ -> CErrors.anomaly(Pp.str - "Future.chain ~pure:false call on an already joined computation") - | Ongoing _ -> CErrors.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."))) + | Val v -> Val (f v)) 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) + | Exn _ -> x := Closure (fun () -> force y) | _ -> CErrors.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 = CErrors.push e in !unfreeze state; Exninfo.iraise e - -let transactify f x = - let state = !freeze () in - try f x - with e -> - let e = CErrors.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); + (Pp.str "A computation can be replaced only if is_exn holds.") + +let chain x f = + let y = chain x f in + if is_over x then ignore(force y); y -let force x = force ~pure:false x let join kx = let v = force kx in @@ -204,16 +170,15 @@ let join kx = 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 split2 x = + chain x (fun x -> fst x), chain x (fun x -> snd x) -let map2 ?greedy f x l = +let map2 f x l = CList.map_i (fun i y -> - let xi = chain ?greedy ~pure:true x (fun x -> + let xi = chain x (fun x -> try List.nth x i with Failure _ | Invalid_argument _ -> - CErrors.anomaly (Pp.str "Future.map2 length mismatch")) in + CErrors.anomaly (Pp.str "Future.map2 length mismatch.")) in f xi y) 0 l let print f kx = @@ -226,6 +191,5 @@ let print f kx = 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) + | Val x -> str "PureVal" ++ 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 index 114c5917..d9e8c87b 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -1,47 +1,19 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - * 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 + * One difference 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 @@ -87,7 +59,7 @@ val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation 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. +(* To get the fix_exn of a computation and build a Lemmas.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 @@ -113,28 +85,17 @@ 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 +(* [chain c f] chains computation [c] with [f]. + * [chain] is eager, that is to say, it won't suspend the new computation + * if the old one is_over (Exn or Val). +*) +val chain : '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. +(* Final call. * 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 @@ -143,25 +104,14 @@ val join : 'a computation -> 'a val sink : 'a computation -> unit (*** Utility functions ************************************************* ***) -val split2 : ?greedy:bool -> +val split2 : ('a * 'b) computation -> 'a computation * 'b computation -val map2 : ?greedy:bool -> +val map2 : ('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 - -type freeze -(* 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 -> freeze) -> (freeze -> unit) -> unit +val print : ('a -> Pp.t) -> 'a computation -> Pp.t -val customize_not_ready_msg : (string -> Pp.std_ppcmds) -> unit -val customize_not_here_msg : (string -> Pp.std_ppcmds) -> unit +val customize_not_ready_msg : (string -> Pp.t) -> unit +val customize_not_here_msg : (string -> Pp.t) -> unit diff --git a/lib/genarg.ml b/lib/genarg.ml index 05c828d5..209d1b27 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* any @@ -58,7 +60,7 @@ fun t1 t2 -> match t1, t2 with end | _ -> None -let rec pr_genarg_type : type a b c. (a, b, c) genarg_type -> std_ppcmds = function +let rec pr_genarg_type : type a b c. (a, b, c) genarg_type -> Pp.t = function | ListArg t -> pr_genarg_type t ++ spc () ++ str "list" | OptArg t -> pr_genarg_type t ++ spc () ++ str "opt" | PairArg (t1, t2) -> @@ -159,7 +161,7 @@ let create_arg name = match ArgT.name name with | None -> ExtraArg (ArgT.create name) | Some _ -> - CErrors.anomaly (str "generic argument already declared: " ++ str name) + CErrors.anomaly (str "generic argument already declared: " ++ str name ++ str ".") let make0 = create_arg @@ -172,19 +174,22 @@ sig val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option end +let get_arg_tag = function +| ExtraArg s -> s +| _ -> assert false + module Register (M : GenObj) = struct module GenMap = ArgMap(struct type ('r, 'g, 't) t = ('r, 'g, 't) M.obj end) let arg0_map = ref GenMap.empty - let register0 arg f = match arg with - | ExtraArg s -> + let register0 arg f = + let s = get_arg_tag arg in if GenMap.mem s !arg0_map then - let msg = str M.name ++ str " function already registered: " ++ str (ArgT.repr s) in + let msg = str M.name ++ str " function already registered: " ++ str (ArgT.repr s) ++ str "." in CErrors.anomaly msg else arg0_map := GenMap.add s (GenMap.Pack f) !arg0_map - | _ -> assert false let get_obj0 name = try @@ -192,13 +197,11 @@ struct with Not_found -> match M.default (ExtraArg name) with | None -> - CErrors.anomaly (str M.name ++ str " function not found: " ++ str (ArgT.repr name)) + CErrors.anomaly (str M.name ++ str " function not found: " ++ str (ArgT.repr name) ++ str ".") | 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 - | ExtraArg s -> get_obj0 s - | _ -> assert false + let obj t = get_obj0 @@ get_arg_tag t end diff --git a/lib/genarg.mli b/lib/genarg.mli index d7ad9b93..bb85f99e 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ('b, 'l) abstract_argument_type -> ('a, 'b) CSig.eq option -val pr_argument_type : argument_type -> Pp.std_ppcmds +val pr_argument_type : argument_type -> Pp.t (** Print a human-readable representation for a given type. *) val genarg_tag : 'a generic_argument -> argument_type @@ -157,6 +159,9 @@ val unquote : ('a, 'co) abstract_argument_type -> argument_type This is boilerplate code used here and there in the code of Coq. *) +val get_arg_tag : ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c) ArgT.tag +(** Works only on base objects (ExtraArg), otherwise fails badly. *) + module type GenObj = sig type ('raw, 'glb, 'top) obj diff --git a/lib/hMap.ml b/lib/hMap.ml deleted file mode 100644 index ea76e742..00000000 --- a/lib/hMap.ml +++ /dev/null @@ -1,406 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 height s = Int.Map.height s - - let is_smaller s1 s2 = height s1 <= height s2 + 3 - - (** Assumes s1 << s2 *) - let fast_union s1 s2 = - let fold h s accu = - try Int.Map.modify h (fun _ s' -> Set.fold Set.add s s') accu - with Not_found -> Int.Map.add h s accu - in - Int.Map.fold fold s1 s2 - - let union s1 s2 = - if is_smaller s1 s2 then fast_union s1 s2 - else if is_smaller s2 s1 then fast_union s2 s1 - else - 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 - - (** Assumes s1 << s2 *) - let fast_inter s1 s2 = - let fold h s accu = - try - let s' = Int.Map.find h s2 in - let si = Set.filter (fun e -> Set.mem e s') s in - if Set.is_empty si then accu - else Int.Map.add h si accu - with Not_found -> accu - in - Int.Map.fold fold s1 Int.Map.empty - - let inter s1 s2 = - if is_smaller s1 s2 then fast_inter s1 s2 - else if is_smaller s2 s1 then fast_inter s2 s1 - else - 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 - - (** Assumes s1 << s2 *) - let fast_diff_l s1 s2 = - let fold h s accu = - try - let s' = Int.Map.find h s2 in - let si = Set.filter (fun e -> not (Set.mem e s')) s in - if Set.is_empty si then accu - else Int.Map.add h si accu - with Not_found -> Int.Map.add h s accu - in - Int.Map.fold fold s1 Int.Map.empty - - (** Assumes s2 << s1 *) - let fast_diff_r s1 s2 = - let fold h s accu = - try - let s' = Int.Map.find h accu in - let si = Set.filter (fun e -> not (Set.mem e s)) s' in - if Set.is_empty si then Int.Map.remove h accu - else Int.Map.update h si accu - with Not_found -> accu - in - Int.Map.fold fold s2 s1 - - let diff s1 s2 = - if is_smaller s1 s2 then fast_diff_l s1 s2 - else if is_smaller s2 s2 then fast_diff_r s1 s2 - else - 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 get k s = try find k s with Not_found -> assert false - - 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 - - let height s = Int.Map.height s - - module Unsafe = - struct - let map f s = - let fs m = Map.Unsafe.map f m in - Int.Map.map fs s - end - - module Monad(M : CMap.MonadS) = - struct - module IntM = Int.Map.Monad(M) - module ExtM = Map.Monad(M) - - let fold f s accu = - let ff _ m accu = ExtM.fold f m accu in - IntM.fold ff s accu - - let fold_left _ _ _ = assert false - let fold_right _ _ _ = assert false - end - -end diff --git a/lib/hMap.mli b/lib/hMap.mli deleted file mode 100644 index c4e6a08e..00000000 --- a/lib/hMap.mli +++ /dev/null @@ -1,28 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index 4eaacf91..00000000 --- a/lib/hashcons.ml +++ /dev/null @@ -1,182 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t1)*(t2->t2)*...). - * [hashcons u x] is a function that hash-cons the sub-structures of x using - * the hash-consing functions u provides. - * [eq] is a comparison function. It is allowed to use physical equality - * 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 HashconsedType = - sig - type t - type u - val hashcons : u -> t -> t - val eq : t -> t -> bool - val hash : t -> int - end - -(** 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 - type table - val generate : u -> table - val hcons : table -> t -> t - val stats : table -> Hashset.statistics - end - -module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = - struct - type t = X.t - type u = X.u - - (* We create the type of hashtables for t, with our comparison fun. - * An invariant is that the table never contains two entries equals - * w.r.t (=), although the equality on keys is X.eq. This is - * granted since we hcons the subterms before looking up in the table. - *) - module Htbl = Hashset.Make(X) - - type table = (Htbl.t * u) - - let generate u = - let tab = Htbl.create 97 in - (tab, u) - - let hcons (tab, u) x = - let y = X.hashcons u x in - Htbl.repr (X.hash y) y tab - - let stats (tab, _) = Htbl.stats tab - - end - -(* A few useful wrappers: - * 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 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 - * The first component will be used to hash-cons the recursive subterms - * The second one to hashcons the other sub-structures. - * We just have to take the fixpoint of h - *) -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 - -(* 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 eq 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 hashcons () s =(* incr accesstr;*) s - external eq : 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 *) -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 comp_obj o1 o2 = - if tuple_p o1 && tuple_p o2 then - let n1 = Obj.size o1 and n2 = Obj.size o2 in - if n1=n2 then - try - for i = 0 to pred n1 do - if not (Obj.field o1 i == Obj.field o2 i) then raise NotEq - done; true - with NotEq -> false - else false - else o1=o2 - -let hash_obj hrec o = - begin - if tuple_p o then - let n = Obj.size o in - for i = 0 to pred n do - Obj.set_field o i (hrec (Obj.field o i)) - done - end; - o - -module Hobj = Make( - struct - type t = Obj.t - type u = (Obj.t -> Obj.t) * unit - let hashcons (hrec,_) = hash_obj hrec - let eq = comp_obj - let hash = Hashtbl.hash - end) diff --git a/lib/hashcons.mli b/lib/hashcons.mli deleted file mode 100644 index 150899ce..00000000 --- a/lib/hashcons.mli +++ /dev/null @@ -1,90 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> t - (** The actual hashconsing function, using its fist argument to recursively - hashcons substructures. It should be compatible with [eq], that is - [eq x (hashcons f x) = true]. *) - val eq : 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 [eq], i.e. if [eq x y = true] then - [hash x = hash y]. *) - end - -module type S = - sig - type t - (** Type of objects to hashcons. *) - type u - (** 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. *) - val stats : table -> Hashset.statistics - (** Recover statistics of the hashconsing table. *) - end - -module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) -(** Create a new hashconsing, given canonicalization functions. *) - -(** {6 Wrappers} *) - -(** These are intended to be used together with instances of the [Make] - functor. *) - -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]. *) - -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} *) - -module type HashedType = sig type t val hash : t -> int end - -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 deleted file mode 100644 index af33544d..00000000 --- a/lib/hashset.ml +++ /dev/null @@ -1,229 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> bool -end - -type statistics = { - num_bindings: int; - num_buckets: int; - max_bucket_length: int; - bucket_histogram: int array -} - -module type S = sig - type elt - type t - val create : int -> t - val clear : t -> unit - val repr : int -> elt -> t -> elt - val stats : t -> statistics -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.eq 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 - - let stats t = - let fold accu bucket = max (count_bucket 0 bucket 0) accu in - let max_length = Array.fold_left fold 0 t.table in - let histogram = Array.make (max_length + 1) 0 in - let iter bucket = - let len = count_bucket 0 bucket 0 in - histogram.(len) <- succ histogram.(len) - in - let () = Array.iter iter t.table in - let fold (num, len, i) k = (num + k * i, len + k, succ i) in - let (num, len, _) = Array.fold_left fold (0, 0, 0) histogram in - { - num_bindings = num; - num_buckets = len; - max_bucket_length = Array.length histogram; - bucket_histogram = histogram; - } - -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 deleted file mode 100644 index 733c8962..00000000 --- a/lib/hashset.mli +++ /dev/null @@ -1,56 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> bool -end - -type statistics = { - num_bindings: int; - num_buckets: int; - max_bucket_length: int; - bucket_histogram: int array -} - -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. *) - val stats : t -> statistics - (** Recover statistics on the table. *) -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/heap.ml b/lib/heap.ml deleted file mode 100644 index 97ccadeb..00000000 --- a/lib/heap.ml +++ /dev/null @@ -1,134 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> int -end - -module type S =sig - - (* Type of functional heaps *) - type t - - (* Type of elements *) - type elt - - (* The empty heap *) - val empty : t - - (* [add x h] returns a new heap containing the elements of [h], plus [x]; - complexity $O(log(n))$ *) - val add : elt -> t -> t - - (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] - when [h] is empty; complexity $O(1)$ *) - val maximum : t -> elt - - (* [remove h] returns a new heap containing the elements of [h], except - the maximum of [h]; raises [EmptyHeap] when [h] is empty; - complexity $O(log(n))$ *) - val remove : t -> t - - (* usual iterators and combinators; elements are presented in - arbitrary order *) - val iter : (elt -> unit) -> t -> unit - - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - -end - -exception EmptyHeap - -(*s Functional implementation *) - -module Functional(X : Ordered) = struct - - (* 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 = - | Leaf - | Node of t * X.t * t - - type elt = X.t - - let empty = Leaf - - let rec add x = function - | 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 - | Leaf -> raise EmptyHeap - | Node (_, x, _) -> x - - let remove = function - | Leaf -> - raise EmptyHeap - | Node (l, _, r) -> - merge l r - - let rec iter f = function - | Leaf -> () - | Node (l, x, r) -> iter f l; f x; iter f r - - let rec fold f h x0 = match h with - | Leaf -> - x0 - | Node (l, x, r) -> - fold f l (fold f r (f x x0)) - -end diff --git a/lib/heap.mli b/lib/heap.mli deleted file mode 100644 index 0e77a3a0..00000000 --- a/lib/heap.mli +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> int -end - -module type S =sig - - (** Type of functional heaps *) - type t - - (** Type of elements *) - type elt - - (** The empty heap *) - val empty : t - - (** [add x h] returns a new heap containing the elements of [h], plus [x]; - complexity {% $ %}O(log(n)){% $ %} *) - val add : elt -> t -> t - - (** [maximum h] returns the maximum element of [h]; raises [EmptyHeap] - when [h] is empty; complexity {% $ %}O(1){% $ %} *) - val maximum : t -> elt - - (** [remove h] returns a new heap containing the elements of [h], except - the maximum of [h]; raises [EmptyHeap] when [h] is empty; - complexity {% $ %}O(log(n)){% $ %} *) - val remove : t -> t - - (** usual iterators and combinators; elements are presented in - arbitrary order *) - val iter : (elt -> unit) -> t -> unit - - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - -end - -exception EmptyHeap - -(** {6 Functional implementation. } *) - -module Functional(X: Ordered) : S with type elt=X.t diff --git a/lib/hook.ml b/lib/hook.ml index a370fe35..1e2a2f27 100644 --- a/lib/hook.ml +++ b/lib/hook.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index 50f5389b..00000000 --- a/lib/iStream.mli +++ /dev/null @@ -1,81 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 deleted file mode 100644 index 70bd7424..00000000 --- a/lib/int.ml +++ /dev/null @@ -1,237 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index 93d1be1f..00000000 --- a/lib/int.mli +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 8791f074..08918594 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -1,21 +1,29 @@ +Coq_config + +Hook +Flags +Control +Util + +Pp +Stateid +Loc +Feedback CErrors CWarnings -Bigint -Segmenttree -Unicodetable -Unicode -Minisys + +Rtree System -CThread -Spawn -Trie -Profile Explore -Predicate -Rtree -Heap -Unionfind -Genarg -CEphemeron +CProfile Future +Spawn + +CAst +DAst +Genarg + RemoteCounter +Aux_file +Envars +CoqProject_file diff --git a/lib/loc.ml b/lib/loc.ml index 0f9864a9..1a09091b 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -1,15 +1,21 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* None + | Some l , None -> Some l + | None, Some l -> Some l + | Some l1, Some l2 -> Some (merge l1 l2) + +let finer l1 l2 = match l1, l2 with + | None, _ -> false + | Some l , None -> true + | Some l1, Some l2 -> l1.fname = l2.fname && merge l1 l2 = l2 + let unloc loc = (loc.bp, loc.ep) -let dummy_loc = ghost -let join_loc = merge +let shift_loc kb kp loc = { loc with bp = loc.bp + kb ; ep = loc.ep + kp } (** Located type *) +type 'a located = t option * 'a -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 +let tag ?loc x = loc, x +let map f (l,x) = (l, f x) (** 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) +let raise ?loc e = + match loc with + | None -> raise e + | Some loc -> + let info = Exninfo.add Exninfo.null location loc in + Exninfo.iraise (e, info) + diff --git a/lib/loc.mli b/lib/loc.mli index c08e097a..23df1ebd 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -1,15 +1,21 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* int -> int -> int -> int -> t +val create : source -> int -> int -> int -> int -> t (** Create a location from a filename, a line number, a position of the beginning of the line, a start and end position *) @@ -35,13 +38,18 @@ val unloc : t -> int * int val make_loc : int * int -> t (** Make a location out of its start and end position *) -val ghost : t -(** Dummy location *) +val merge : t -> t -> t +val merge_opt : t option -> t option -> t option +(** Merge locations, usually generating the largest possible span *) -val is_ghost : t -> bool -(** Test whether the location is meaningful *) +val finer : t option -> t option -> bool +(** Answers [true] when the first location is more defined, or, when + both defined, included in the second one *) -val merge : t -> t -> t +val shift_loc : int -> int -> t -> t +(** [shift_loc loc n p] shifts the beginning of location by [n] and + the end by [p]; it is assumed that the shifts do not change the + lines at which the location starts and ends *) (** {5 Located exceptions} *) @@ -51,21 +59,15 @@ val add_loc : Exninfo.info -> t -> Exninfo.info val get_loc : Exninfo.info -> t option (** Retrieving the optional location of an exception *) -val raise : t -> exn -> 'a +val raise : ?loc: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 +(** {5 Objects with location information } *) -val down_located : ('a -> 'b) -> 'a located -> 'b -(** Projects out a located object *) +type 'a located = t option * 'a -(** {5 Backward compatibility} *) - -val dummy_loc : t -(** Same as [ghost] *) +val tag : ?loc:t -> 'a -> 'a located +(** Embed a location in a type *) -val join_loc : t -> t -> t -(** Same as [merge] *) +val map : ('a -> 'b) -> 'a located -> 'b located +(** Modify an object carrying a location *) diff --git a/lib/minisys.ml b/lib/minisys.ml deleted file mode 100644 index f15021c6..00000000 --- a/lib/minisys.ml +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* true | _ -> false)*) - -(* Check directory can be opened *) - -let exists_dir dir = - try Sys.is_directory dir with Sys_error _ -> false - -let apply_subdir f path name = - (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) - (* as well as skipped files like CVS, ... *) - if ok_dirname name then - let path = if path = "." then name else path//name in - match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with - | Unix.S_DIR -> f (FileDir (path,name)) - | Unix.S_REG -> f (FileRegular name) - | _ -> () - -let readdir dir = try Sys.readdir dir with any -> [||] - -let process_directory f path = - Array.iter (apply_subdir f path) (readdir path) - -let process_subdirectories f path = - let f = function FileDir (path,base) -> f path base | FileRegular _ -> () in - process_directory f path diff --git a/lib/monad.ml b/lib/monad.ml deleted file mode 100644 index 2e55e969..00000000 --- a/lib/monad.ml +++ /dev/null @@ -1,168 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 - - (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*) - val map_filter : ('a -> 'b option t) -> 'a list -> 'b list 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_right 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 map_filter f = function - | [] -> return [] - | a::l -> - f a >>= function - | None -> map_filter f l - | Some b -> - map_filter f l >>= fun filtered -> - return (b::filtered) - - 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 deleted file mode 100644 index f7de71f5..00000000 --- a/lib/monad.mli +++ /dev/null @@ -1,93 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 - - (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*) - val map_filter : ('a -> 'b option t) -> 'a list -> 'b list 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 deleted file mode 100644 index fbb883d3..00000000 --- a/lib/option.ml +++ /dev/null @@ -1,191 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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]. - @raise [IsNone] if [x] equals [None]. *) -let get = function - | Some y -> y - | _ -> raise IsNone - -(** [make x] returns [Some x]. *) -let make x = Some x - -(** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *) -let init b x = - if b then - Some x - else - None - - -(** [flatten x] is [Some y] if [x] is [Some (Some y)] and [None] otherwise. *) -let flatten = function - | Some (Some y) -> Some y - | _ -> 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 - otherwise. *) -let iter f = function - | Some y -> f y - | _ -> () - - -exception Heterogeneous - -(** [iter2 f x y] executes [f z w] if [x] equals [Some z] and [y] equals - [Some w]. It does nothing if both [x] and [y] are [None]. And raises - [Heterogeneous] otherwise. *) -let iter2 f x y = - match x,y with - | Some z, Some w -> f z w - | None,None -> () - | _,_ -> raise Heterogeneous - -(** [map f x] is [None] if [x] is [None] and [Some (f y)] if [x] is [Some y]. *) -let map f = function - | Some y -> Some (f y) - | _ -> None - -(** [smartmap f x] does the same as [map f x] except that it tries to share - some memory. *) -let smartmap f = function - | Some y as x -> let y' = f y in if y' == y then x else Some y' - | _ -> None - -(** [fold_left f a x] is [f a y] if [x] is [Some y], and [a] otherwise. *) -let fold_left f a = function - | Some y -> f a y - | _ -> a - -(** [fold_left2 f a x y] is [f z w] if [x] is [Some z] and [y] is [Some w]. - It is [a] if both [x] and [y] are [None]. Otherwise it raises - [Heterogeneous]. *) -let fold_left2 f a x y = - match x,y with - | Some x, Some y -> f a x y - | None, None -> a - | _ -> raise Heterogeneous - -(** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) -let fold_right f x a = - match x with - | Some y -> f y a - | _ -> a - -(** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) -let fold_map f a x = - match x with - | Some y -> let a, z = f a y in a, Some z - | _ -> a, None - -(** [cata f a x] is [a] if [x] is [None] and [f y] if [x] is [Some y]. *) -let cata f a = function - | Some c -> f c - | None -> a - -(** {6 More Specific operations} ***) - -(** [default a x] is [y] if [x] is [Some y] and [a] otherwise. *) -let default a = function - | Some y -> y - | _ -> a - -(** [lift f x] is the same as [map f x]. *) -let lift = map - -(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and - [None] otherwise. *) -let lift_right f a = function - | Some y -> Some (f a y) - | _ -> None - -(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and - [None] otherwise. *) -let lift_left f x a = - match x with - | Some y -> Some (f y a) - | _ -> None - -(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals - [Some w]. It is [None] otherwise. *) -let lift2 f x y = - match x,y with - | Some z, Some w -> Some (f z w) - | _,_ -> None - - - -(** {6 Operations with Lists} *) - -module List = - struct - (** [List.cons x l] equals [y::l] if [x] is [Some y] and [l] otherwise. *) - let cons x l = - match x with - | Some y -> y::l - | _ -> l - - (** [List.flatten l] is the list of all the [y]s such that [l] contains - [Some y] (in the same order). *) - let rec flatten = function - | x::l -> cons x (flatten l) - | [] -> [] - - let rec find f = function - |[] -> None - |h :: t -> match f h with - |None -> find f t - |x -> x - -end diff --git a/lib/option.mli b/lib/option.mli deleted file mode 100644 index 5e085620..00000000 --- a/lib/option.mli +++ /dev/null @@ -1,126 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool - -(** 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]. - @raise IsNone if [x] equals [None]. *) -val get : 'a option -> 'a - -(** [make x] returns [Some x]. *) -val make : 'a -> 'a option - -(** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *) -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"} *) - -(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing - otherwise. *) -val iter : ('a -> unit) -> 'a option -> unit - -exception Heterogeneous - -(** [iter2 f x y] executes [f z w] if [x] equals [Some z] and [y] equals - [Some w]. It does nothing if both [x] and [y] are [None]. - @raise Heterogeneous otherwise. *) -val iter2 : ('a -> 'b -> unit) -> 'a option -> 'b option -> unit - -(** [map f x] is [None] if [x] is [None] and [Some (f y)] if [x] is [Some y]. *) -val map : ('a -> 'b) -> 'a option -> 'b option - -(** [smartmap f x] does the same as [map f x] except that it tries to share - some memory. *) -val smartmap : ('a -> 'a) -> 'a option -> 'a option - -(** [fold_left f a x] is [f a y] if [x] is [Some y], and [a] otherwise. *) -val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b - -(** [fold_left2 f a x y] is [f z w] if [x] is [Some z] and [y] is [Some w]. - It is [a] if both [x] and [y] are [None]. - @raise Heterogeneous otherwise. *) -val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option -> 'c option -> 'a - -(** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) -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 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} *) - -(** [default a x] is [y] if [x] is [Some y] and [a] otherwise. *) -val default : 'a -> 'a option -> 'a - -(** [lift] is the same as {!map}. *) -val lift : ('a -> 'b) -> 'a option -> 'b option - -(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and - [None] otherwise. *) -val lift_right : ('a -> 'b -> 'c) -> 'a -> 'b option -> 'c option - -(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and - [None] otherwise. *) -val lift_left : ('a -> 'b -> 'c) -> 'a option -> 'b -> 'c option - -(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals - [Some w]. It is [None] otherwise. *) -val lift2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option - - -(** {6 Operations with Lists} *) - -module List : sig - (** [List.cons x l] equals [y::l] if [x] is [Some y] and [l] otherwise. *) - val cons : 'a option -> 'a list -> 'a list - - (** [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 - - val find : ('a -> 'b option) -> 'a list -> 'b option -end diff --git a/lib/pp.ml b/lib/pp.ml index f3bb4753..cd81f6e7 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -1,69 +1,13 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 - -end = struct - - type 'a t = GEmpty | GLeaf of 'a | GNode of 'a t * 'a t - - let atom x = GLeaf x - - let glue x y = - match x, y with - | GEmpty, _ -> y - | _, GEmpty -> x - | _, _ -> GNode (x,y) - - let empty = GEmpty - - let is_empty x = x = GEmpty - - let rec iter f = function - | GEmpty -> () - | GLeaf x -> f x - | GNode (x,y) -> iter f x; iter f y - -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 - -module Dyn = Dyn.Make(struct end) - -type t = Dyn.t -type 'a key = 'a Dyn.tag -let create = Dyn.create -let inj = Dyn.Easy.inj -let prj = Dyn.Easy.prj - -end - -open Pp_control - (* The different kinds of blocks are: \begin{description} \item[hbox:] Horizontal block no line breaking; @@ -72,54 +16,37 @@ open Pp_control 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} *) +type pp_tag = string + type block_type = - | Pp_hbox of int - | Pp_vbox of int - | Pp_hvbox of int + | 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) +type doc_view = + | Ppcmd_empty + | Ppcmd_string of string + | Ppcmd_glue of doc_view list + | Ppcmd_box of block_type * doc_view + | Ppcmd_tag of pp_tag * doc_view + (* Are those redundant? *) | 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 string list - | 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 +(* Following discussion on #390, we play on the safe side and make the + internal representation opaque here. *) +type t = doc_view -type std_ppcmds = ppcmd Glue.t +type std_ppcmds = t +[@@ocaml.deprecated "alias of Pp.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 repr x = x +let unrepr x = x (* Compute length of an UTF-8 encoded string Rem 1 : utf8_length <= String.length (equal if pure ascii) @@ -157,25 +84,43 @@ let utf8_length s = done ; !cnt +let rec app d1 d2 = match d1, d2 with + | Ppcmd_empty, d + | d, Ppcmd_empty -> d + + (* Optimizations *) + | Ppcmd_glue [l1;l2], Ppcmd_glue l3 -> Ppcmd_glue (l1 :: l2 :: l3) + | Ppcmd_glue [l1;l2], d2 -> Ppcmd_glue [l1 ; l2 ; d2] + | d1, Ppcmd_glue l2 -> Ppcmd_glue (d1 :: l2) + + | Ppcmd_tag(t1,d1), Ppcmd_tag(t2,d2) + when t1 = t2 -> Ppcmd_tag(t1,app d1 d2) + | d1, d2 -> Ppcmd_glue [d1; d2] + (* Optimizations deemed too costly *) + (* | Ppcmd_glue l1, Ppcmd_glue l2 -> Ppcmd_glue (l1 @ l2) *) + (* | Ppcmd_string s1, Ppcmd_string s2 -> Ppcmd_string (s1 ^ s2) *) + +let seq s = Ppcmd_glue s + +let (++) = app + (* 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 l = Glue.atom(Ppcmd_comment l) +let str s = Ppcmd_string s +let brk (a,b) = Ppcmd_print_break (a,b) +let fnl () = Ppcmd_force_newline +let ws n = Ppcmd_print_break (n,0) +let comment l = Ppcmd_comment l (* 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 mt () = Ppcmd_empty +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) + +(* XXX: To Remove *) let strbrk s = let rec aux p n = if n < String.length s then @@ -184,50 +129,18 @@ let strbrk s = 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 pr_loc_pos loc = - if Loc.is_ghost loc then (str"") - else - let loc = Loc.unloc loc in - int (fst loc) ++ str"-" ++ int (snd loc) - -let pr_loc loc = - if Loc.is_ghost loc then str"" ++ fnl () - else - let fname = loc.Loc.fname in - if CString.equal fname "" then - Loc.(str"Toplevel input, characters " ++ int loc.bp ++ - str"-" ++ int loc.ep ++ str":" ++ fnl ()) - else - Loc.(str"File " ++ str "\"" ++ str fname ++ str "\"" ++ - str", line " ++ int loc.line_nb ++ str", characters " ++ - int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ - str":" ++ fnl()) + in Ppcmd_glue (aux 0 0) -let ismt = is_empty +let ismt = function | Ppcmd_empty -> true | _ -> false (* 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) +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) (* 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 +let tag t s = Ppcmd_tag(t,s) (* In new syntax only double quote char is escaped by repeating it *) let escape_string s = @@ -254,71 +167,34 @@ let rec pr_com ft s = Some s2 -> 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 +let pp_with ft pp = + let cpp_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 - Format.pp_print_as ft n s - | Str_len (s, n) -> - Format.pp_print_as ft n s - end - | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - 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 -> pp_open_box bty - | Ppcmd_close_box -> Format.pp_close_box ft () - | Ppcmd_close_tbox -> Format.pp_close_tbox ft () - | Ppcmd_white_space n -> Format.pp_print_break ft n 0 - | Ppcmd_print_break(m,n) -> Format.pp_print_break ft m n - | Ppcmd_set_tab -> Format.pp_set_tab ft () - | Ppcmd_print_tbreak(m,n) -> Format.pp_print_tbreak ft m n - | Ppcmd_force_newline -> Format.pp_force_newline ft () - | Ppcmd_print_if_broken -> Format.pp_print_if_newline ft () + let rec pp_cmd = let open Format in function + | Ppcmd_empty -> () + | Ppcmd_glue sl -> List.iter pp_cmd sl + | Ppcmd_string str -> let n = utf8_length str in + pp_print_as ft n str + | Ppcmd_box(bty,ss) -> cpp_open_box bty ; + if not (over_max_boxes ()) then pp_cmd ss; + pp_close_box ft () + | Ppcmd_print_break(m,n) -> pp_print_break ft m n + | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms - | 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 + | Ppcmd_tag(tag, s) -> pp_open_tag ft tag; + pp_cmd s; + pp_close_tag ft () in - let pp_dir = function - | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream - | Ppdir_print_newline -> Format.pp_print_newline ft () - | Ppdir_print_flush -> Format.pp_print_flush ft () - in - fun (dirstream : _ ppdirs) -> - try - Glue.iter pp_dir dirstream - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - let () = Format.pp_print_flush ft () in - Exninfo.iraise reraise - -(* pretty printing functions WITHOUT FLUSH *) -let pp_with ?pp_tag ft strm = - pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm)) - -(* pretty printing functions WITH FLUSH *) -let msg_with ?pp_tag ft strm = - pp_dirs ?pp_tag ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) + try pp_cmd pp + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = Format.pp_print_flush ft () in + Exninfo.iraise reraise (* If mixing some output and a goal display, please use msg_warning, so that interfaces (proofgeneral for example) can easily dispatch @@ -326,7 +202,7 @@ let msg_with ?pp_tag ft strm = (** Output to a string formatter *) let string_of_ppcmds c = - Format.fprintf Format.str_formatter "@[%a@]" (msg_with ?pp_tag:None) c; + Format.fprintf Format.str_formatter "@[%a@]" pp_with c; Format.flush_str_formatter () (* Copy paste from Util *) @@ -334,6 +210,7 @@ let string_of_ppcmds c = let pr_comma () = str "," ++ spc () let pr_semicolon () = str ";" ++ spc () let pr_bar () = str "|" ++ spc () +let pr_spcbar () = str " |" ++ spc () let pr_arg pr x = spc () ++ pr x let pr_non_empty_arg pr x = let pp = pr x in if ismt pp then mt () else spc () ++ pr x let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x @@ -353,29 +230,31 @@ let pr_nth n = (* [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 +let prlist pr l = Ppcmd_glue (List.map pr 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_sep_lastsep no_empty sep_thunk lastsep_thunk elem l = + let sep = sep_thunk () in + let lastsep = lastsep_thunk () in + let elems = List.map elem l in + let filtered_elems = + if no_empty then + List.filter (fun e -> not (ismt e)) elems + else + elems + in + let rec insert_seps es = + match es with + | [] -> mt () + | [e] -> e + | h::[e] -> h ++ lastsep ++ e + | h::t -> h ++ sep ++ insert_seps t + in + insert_seps filtered_elems + 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] *) @@ -418,4 +297,3 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v let prvect elem v = prvect_with_sep mt elem v let surround p = hov 1 (str"(" ++ p ++ str")") - diff --git a/lib/pp.mli b/lib/pp.mli index 8342a983..f3a0a29b 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -1,179 +1,191 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds -val stras : int * string -> std_ppcmds -val brk : int * int -> std_ppcmds -val tbrk : int * int -> std_ppcmds -val tab : unit -> std_ppcmds -val fnl : unit -> std_ppcmds -val pifb : unit -> std_ppcmds -val ws : int -> std_ppcmds -val mt : unit -> std_ppcmds -val ismt : std_ppcmds -> bool - -val comment : string list -> std_ppcmds - -(** {6 Manipulation commands} *) +(** Coq document type. *) + +(** Pretty printing guidelines ******************************************) +(* *) +(* `Pp.t` is the main pretty printing document type *) +(* in the Coq system. Documents are composed laying out boxes, and *) +(* users can add arbitrary tag metadata that backends are free *) +(* to interpret. *) +(* *) +(* The datatype has a public view to allow serialization or advanced *) +(* uses, however regular users are _strongly_ warned againt its use, *) +(* they should instead rely on the available functions below. *) +(* *) +(* Box order and number is indeed an important factor. Try to create *) +(* a proper amount of boxes. The `++` operator provides "efficient" *) +(* concatenation, but using the list constructors is usually preferred. *) +(* *) +(* That is to say, this: *) +(* *) +(* `hov [str "Term"; hov (pr_term t); str "is defined"]` *) +(* *) +(* is preferred to: *) +(* *) +(* `hov (str "Term" ++ hov (pr_term t) ++ str "is defined")` *) +(* *) +(************************************************************************) -val app : std_ppcmds -> std_ppcmds -> std_ppcmds -(** Concatenation. *) +(* XXX: Improve and add attributes *) +type pp_tag = string -val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds -(** Infix alias for [app]. *) +(* Following discussion on #390, we play on the safe side and make the + internal representation opaque here. *) +type t -val eval_ppcmds : std_ppcmds -> std_ppcmds -(** Force computation. *) +type std_ppcmds = t +[@@ocaml.deprecated "alias of Pp.t"] -val is_empty : std_ppcmds -> bool -(** Test emptyness. *) +type block_type = + | Pp_hbox of int + | Pp_vbox of int + | Pp_hvbox of int + | Pp_hovbox of int -(** {6 Derived commands} *) +type doc_view = + | Ppcmd_empty + | Ppcmd_string of string + | Ppcmd_glue of t list + | Ppcmd_box of block_type * t + | Ppcmd_tag of pp_tag * t + (* Are those redundant? *) + | Ppcmd_print_break of int * int + | Ppcmd_force_newline + | Ppcmd_comment of string list -val spc : unit -> std_ppcmds -val cut : unit -> std_ppcmds -val align : unit -> std_ppcmds -val int : int -> std_ppcmds -val real : float -> std_ppcmds -val bool : bool -> std_ppcmds -val qstring : string -> std_ppcmds -val qs : string -> std_ppcmds -val quote : std_ppcmds -> std_ppcmds -val strbrk : string -> std_ppcmds +val repr : t -> doc_view +val unrepr : doc_view -> t -(** {6 Boxing commands} *) +(** {6 Formatting commands} *) -val h : int -> std_ppcmds -> std_ppcmds -val v : int -> std_ppcmds -> std_ppcmds -val hv : int -> std_ppcmds -> std_ppcmds -val hov : int -> std_ppcmds -> std_ppcmds -val t : std_ppcmds -> std_ppcmds +val str : string -> t +val brk : int * int -> t +val fnl : unit -> t +val ws : int -> t +val mt : unit -> t +val ismt : t -> bool -(** {6 Opening and closing of boxes} *) +val comment : string list -> t -val hb : int -> std_ppcmds -val vb : int -> std_ppcmds -val hvb : int -> std_ppcmds -val hovb : int -> std_ppcmds -val tb : unit -> std_ppcmds -val close : unit -> std_ppcmds -val tclose : unit -> std_ppcmds +(** {6 Manipulation commands} *) -(** {6 Opening and closing of tags} *) +val app : t -> t -> t +(** Concatenation. *) -module Tag : -sig - type t - (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *) +val seq : t list -> t +(** Multi-Concatenation. *) - type 'a key - (** Keys used to inject tags *) +val (++) : t -> t -> t +(** Infix alias for [app]. *) - 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. *) +(** {6 Derived commands} *) - val inj : 'a -> 'a key -> t - (** Inject an object into a tag. *) +val spc : unit -> t +val cut : unit -> t +val align : unit -> t +val int : int -> t +val real : float -> t +val bool : bool -> t +val qstring : string -> t +val qs : string -> t +val quote : t -> t +val strbrk : string -> t - val prj : t -> 'a key -> 'a option - (** Project an object from a tag. *) -end +(** {6 Boxing commands} *) -val tag : Tag.t -> std_ppcmds -> std_ppcmds -val open_tag : Tag.t -> std_ppcmds -val close_tag : unit -> std_ppcmds +val h : int -> t -> t +val v : int -> t -> t +val hv : int -> t -> t +val hov : int -> t -> t -(** {6 Utilities} *) +(** {6 Tagging} *) -val string_of_ppcmds : std_ppcmds -> string +val tag : pp_tag -> t -> t (** {6 Printing combinators} *) -val pr_comma : unit -> std_ppcmds +val pr_comma : unit -> t (** Well-spaced comma. *) -val pr_semicolon : unit -> std_ppcmds +val pr_semicolon : unit -> t (** Well-spaced semicolon. *) -val pr_bar : unit -> std_ppcmds +val pr_bar : unit -> t (** Well-spaced pipe bar. *) -val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds +val pr_spcbar : unit -> t +(** Pipe bar with space before and after. *) + +val pr_arg : ('a -> t) -> 'a -> t (** Adds a space in front of its argument. *) -val pr_non_empty_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds +val pr_non_empty_arg : ('a -> t) -> 'a -> t (** Adds a space in front of its argument if non empty. *) -val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +val pr_opt : ('a -> t) -> 'a option -> t (** Inner object preceded with a space if [Some], nothing otherwise. *) -val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +val pr_opt_no_spc : ('a -> t) -> 'a option -> t (** Same as [pr_opt] but without the leading space. *) -val pr_nth : int -> std_ppcmds +val pr_nth : int -> t (** Ordinal number with the correct suffix (i.e. "st", "nd", "th", etc.). *) -val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val prlist : ('a -> t) -> 'a list -> t (** 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 +val prlist_strict : ('a -> t) -> 'a list -> t (** Same as [prlist], but strict. *) val prlist_with_sep : - (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a list -> std_ppcmds + (unit -> t) -> ('a -> t) -> 'a list -> t (** [prlist_with_sep sep pr [a ; ... ; c]] outputs - [pr a ++ sep() ++ ... ++ sep() ++ pr c]. *) + [pr a ++ sep () ++ ... ++ sep () ++ pr c]. + where the thunk sep is memoized, rather than being called each place + its result is used. +*) -val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds +val prvect : ('a -> t) -> 'a array -> t (** As [prlist], but on arrays. *) -val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds +val prvecti : (int -> 'a -> t) -> 'a array -> t (** Indexed version of [prvect]. *) val prvect_with_sep : - (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds + (unit -> t) -> ('a -> t) -> 'a array -> t (** As [prlist_with_sep], but on arrays. *) val prvecti_with_sep : - (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds + (unit -> t) -> (int -> 'a -> t) -> 'a array -> t (** Indexed version of [prvect_with_sep]. *) -val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val pr_enum : ('a -> t) -> 'a list -> t (** [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 +val pr_sequence : ('a -> t) -> 'a list -> t (** Sequence of objects separated by space (unless an element is empty). *) -val surround : std_ppcmds -> std_ppcmds +val surround : t -> t (** Surround with parenthesis. *) -val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds - -val pr_loc : Loc.t -> std_ppcmds - -(** {6 Low-level pretty-printing functions with and without flush} *) +val pr_vertical_list : ('b -> t) -> 'b list -> t -(** FIXME: These ignore the logging settings and call [Format] directly *) -type tag_handler = Tag.t -> Format.tag +(** {6 Main renderers, to formatter and to string } *) -(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt] *) -val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit +(** [pp_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) +val pp_with : Format.formatter -> t -> unit -(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) -val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit +val string_of_ppcmds : t -> string diff --git a/lib/pp_control.ml b/lib/pp_control.ml deleted file mode 100644 index 890ffe0a..00000000 --- a/lib/pp_control.ml +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* pp_global_params -> unit - * set the parameters of a formatter *) - -let set_gp ft gp = - Format.pp_set_margin ft gp.margin ; - Format.pp_set_max_indent ft gp.max_indent ; - Format.pp_set_max_boxes ft gp.max_depth ; - Format.pp_set_ellipsis_text ft gp.ellipsis - -let set_dflt_gp ft = set_gp ft dflt_gp - -let get_gp ft = - { margin = Format.pp_get_margin ft (); - max_indent = Format.pp_get_max_indent ft (); - max_depth = Format.pp_get_max_boxes ft (); - ellipsis = Format.pp_get_ellipsis_text ft () } - -(* with_fp : 'a pp_formatter_params -> Format.formatter - * returns of formatter for given formatter functions *) - -let with_fp chan out_function flush_function = - let ft = Format.make_formatter out_function flush_function in - Format.pp_set_formatter_out_channel ft chan; - ft - -(* Output on a channel ch *) - -let with_output_to ch = - let ft = with_fp ch (output ch) (fun () -> flush ch) in - set_gp ft deep_gp; - ft - -let std_ft = ref Format.std_formatter -let _ = set_dflt_gp !std_ft - -let err_ft = ref Format.err_formatter -let _ = set_gp !err_ft deep_gp - -let deep_ft = ref (with_output_to stdout) -let _ = set_gp !deep_ft deep_gp - -(* For parametrization through vernacular *) -let default = Format.pp_get_max_boxes !std_ft () -let default_margin = Format.pp_get_margin !std_ft () - -let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ()) -let set_depth_boxes v = - Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> 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; - (* Heuristic, based on usage: the column on the right of max_indent - column is 20% of width, capped to 30 characters *) - let m = max (64 * v / 100) (v-30) in - Format.pp_set_max_indent Format.str_formatter m; - Format.pp_set_max_indent !std_ft m; - Format.pp_set_max_indent !deep_ft m diff --git a/lib/pp_control.mli b/lib/pp_control.mli deleted file mode 100644 index d26f89eb..00000000 --- a/lib/pp_control.mli +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* pp_global_params -> unit -val set_dflt_gp : Format.formatter -> unit -val get_gp : Format.formatter -> pp_global_params - - -(** {6 Output functions of pretty-printing. } *) - -val with_output_to : out_channel -> Format.formatter - -val std_ft : Format.formatter ref -val err_ft : Format.formatter ref -val deep_ft : Format.formatter ref - -(** {6 For parametrization through vernacular. } *) - -val set_depth_boxes : int option -> unit -val get_depth_boxes : unit -> int option - -val set_margin : int option -> unit -val get_margin : unit -> int option diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml deleted file mode 100644 index aa47c516..00000000 --- a/lib/ppstyle.ml +++ /dev/null @@ -1,73 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false - -let set_style tag st = - try tags := String.Map.update tag st !tags with Not_found -> assert false - -let clear_styles () = - tags := String.Map.map (fun _ -> None) !tags - -let dump () = String.Map.bindings !tags - -let parse_config s = - let styles = Terminal.parse s in - let set accu (name, st) = - try String.Map.update name (Some st) accu with Not_found -> accu - in - tags := List.fold_left set !tags styles - -let tag = Pp.Tag.create "ppstyle" - -(** Default tag is to reset everything *) -let default = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; -}) - -let empty = Terminal.make () - -let error_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in - make ~style ["message"; "error"] - -let warning_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () in - make ~style ["message"; "warning"] - -let debug_tag = - let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in - make ~style ["message"; "debug"] - -let pp_tag t = match Pp.Tag.prj t tag with -| None -> "" -| Some key -> key diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli deleted file mode 100644 index d9fd7576..00000000 --- a/lib/ppstyle.mli +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* string list -> t -(** Create a new tag with the given name. Each name must be unique. The optional - style is taken as the default one. *) - -val repr : t -> string list -(** Gives back the original name of the style tag where each string has been - concatenated and separated with a dot. *) - -val tag : t Pp.Tag.key -(** An annotation for styles *) - -(** {5 Manipulating global styles} *) - -val get_style : t -> Terminal.style option -(** Get the style associated to a tag. *) - -val set_style : t -> Terminal.style option -> unit -(** Set a style associated to a tag. *) - -val clear_styles : unit -> unit -(** Clear all styles. *) - -val parse_config : string -> unit -(** Add all styles from the given string as parsed by {!Terminal.parse}. - Unregistered tags are ignored. *) - -val dump : unit -> (t * Terminal.style option) list -(** Recover the list of known tags together with their current style. *) - -(** {5 Color output} *) - -val pp_tag : Pp.tag_handler -(** Returns the name of a style tag that is understandable by the formatters - that have been inititialized through {!init_color_output}. To be used with - {!Pp.pp_with}. *) - -(** {5 Tags} *) - -val error_tag : t -(** Tag used by the {!Pp.msg_error} function. *) - -val warning_tag : t -(** Tag used by the {!Pp.msg_warning} function. *) - -val debug_tag : t -(** Tag used by the {!Pp.msg_debug} function. *) diff --git a/lib/predicate.ml b/lib/predicate.ml deleted file mode 100644 index 1aa7db6a..00000000 --- a/lib/predicate.ml +++ /dev/null @@ -1,98 +0,0 @@ -(************************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License. *) -(* *) -(************************************************************************) - -module type OrderedType = - sig - type t - val compare: t -> t -> int - end - -module type S = - sig - type elt - type t - val empty: t - val full: t - val is_empty: t -> bool - val is_full: t -> bool - val mem: elt -> t -> bool - val singleton: elt -> t - val add: elt -> t -> t - val remove: elt -> t -> t - val union: t -> t -> t - val inter: t -> t -> t - val diff: t -> t -> t - val complement: t -> t - val equal: t -> t -> bool - val subset: t -> t -> bool - val elements: t -> bool * elt list - end - -module Make(Ord: OrderedType) = - struct - module EltSet = Set.Make(Ord) - - type elt = Ord.t - - (* (false, s) represents a set which is equal to the set s - (true, s) represents a set which is equal to the complement of set s *) - type t = bool * EltSet.t - - let elements (b,s) = (b, EltSet.elements s) - - let empty = (false,EltSet.empty) - 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 mem x (b,s) = - if b then not (EltSet.mem x s) else EltSet.mem x s - - let singleton x = (false,EltSet.singleton x) - - let add x (b,s) = - if b then (b,EltSet.remove x s) - else (b,EltSet.add x s) - - let remove x (b,s) = - if b then (b,EltSet.add x s) - else (b,EltSet.remove x s) - - let complement (b,s) = (not b, s) - - let union s1 s2 = - match (s1,s2) with - ((false,p1),(false,p2)) -> (false,EltSet.union p1 p2) - | ((true,n1),(true,n2)) -> (true,EltSet.inter n1 n2) - | ((false,p1),(true,n2)) -> (true,EltSet.diff n2 p1) - | ((true,n1),(false,p2)) -> (true,EltSet.diff n1 p2) - - let inter s1 s2 = - complement (union (complement s1) (complement s2)) - - let diff s1 s2 = inter s1 (complement s2) - - (* assumes the set is infinite *) - let subset s1 s2 = - match (s1,s2) with - ((false,p1),(false,p2)) -> EltSet.subset p1 p2 - | ((true,n1),(true,n2)) -> EltSet.subset n2 n1 - | ((false,p1),(true,n2)) -> EltSet.is_empty (EltSet.inter p1 n2) - | ((true,_),(false,_)) -> false - - (* assumes the set is infinite *) - let equal (b1,s1) (b2,s2) = - b1=b2 && EltSet.equal s1 s2 - - end diff --git a/lib/predicate.mli b/lib/predicate.mli deleted file mode 100644 index cee3b0bd..00000000 --- a/lib/predicate.mli +++ /dev/null @@ -1,84 +0,0 @@ -(** Infinite sets over a chosen [OrderedType]. - - All operations over sets are purely applicative (no side-effects). - *) - -(** Input signature of the functor [Make]. *) -module type OrderedType = - sig - type t - (** The type of the elements in the set. - - The chosen [t] {b must be infinite}. *) - - val compare : t -> t -> int - (** A total ordering function over the set elements. - This is a two-argument function [f] such that: - - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - *) - end - -module type S = - sig - type elt - (** The type of the elements in the set. *) - - type t - (** The type of sets. *) - - val empty: t - (** The empty set. *) - - val full: t - (** The set of all elements (of type [elm]). *) - - val is_empty: t -> bool - (** Test whether a set is empty or not. *) - - val is_full: t -> bool - (** Test whether a set contains the whole type or not. *) - - val mem: elt -> t -> bool - (** [mem x s] tests whether [x] belongs to the set [s]. *) - - val singleton: elt -> t - (** [singleton x] returns the one-element set containing only [x]. *) - - val add: elt -> t -> t - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], then [s] is returned unchanged. *) - - val remove: elt -> t -> t - (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], then [s] is returned unchanged. *) - - val union: t -> t -> t - (** Set union. *) - - val inter: t -> t -> t - (** Set intersection. *) - - val diff: t -> t -> t - (** Set difference. *) - - val complement: t -> t - (** Set complement. *) - - val equal: t -> t -> bool - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) - - val subset: t -> t -> bool - (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) - - val elements: t -> bool * elt list - (** Gives a finite representation of the predicate: if the - boolean is false, then the predicate is given in extension. - if it is true, then the complement is given *) - end - -(** The [Make] functor constructs an implementation for any [OrderedType]. *) -module Make (Ord : OrderedType) : (S with type elt = Ord.t) diff --git a/lib/profile.ml b/lib/profile.ml deleted file mode 100644 index d620fe69..00000000 --- a/lib/profile.ml +++ /dev/null @@ -1,713 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* e::l - -let magic = 1249 - -let merge_profile filename (curr_table, curr_outside, curr_total as new_data) = - let (old_table, old_outside, old_total) = - try - let c = open_in filename in - if input_binary_int c <> magic - then Printf.printf "Incompatible recording file: %s\n" filename; - let old_data = input_value c in - close_in c; - old_data - with Sys_error msg -> - (Printf.printf "Unable to open %s: %s\n" filename msg; - new_data) in - let updated_data = - let updated_table = List.fold_right ajoute_to_list curr_table old_table in - ajoute curr_outside old_outside; - ajoute curr_total old_total; - (updated_table, old_outside, old_total) in - begin - (try - let c = - open_out_gen - [Open_creat;Open_wronly;Open_trunc;Open_binary] 0o644 filename in - output_binary_int c magic; - output_value c updated_data; - close_out c - with Sys_error _ -> Printf.printf "Unable to create recording file"); - updated_data - end - -(************************************************) -(* Compute a rough estimation of time overheads *) - -(* Time and space are not measured in the same way *) - -(* Byte allocation is an exact number and for long runs, the total - number of allocated bytes may exceed the maximum integer capacity - (2^31 on 32-bits architectures); therefore, allocation is measured - by small steps, total allocations are computed by adding elementary - measures and carries are controlled from step to step *) - -(* Unix measure of time is approximate and short delays are often - unperceivable; therefore, total times are measured in one (big) - step to avoid rounding errors and to get the best possible - approximation. - Note: Sys.time is the same as: - Unix.(let x = times () in x.tms_utime +. x.tms_stime) - *) - -(* ----------- start profile for f1 -overheadA| ... - ---------- [1w1] 1st call to get_time for f1 - overheadB| ... - ---------- start f1 - real 1 | ... - ---------- start profile for 1st call to f2 inside f1 - overheadA| ... - ---------- [2w1] 1st call to get_time for 1st f2 - overheadB| ... - ---------- start 1st f2 - real 2 | ... - ---------- end 1st f2 - overheadC| ... - ---------- [2w1] 2nd call to get_time for 1st f2 - overheadD| ... - ---------- end profile for 1st f2 - real 1 | ... - ---------- start profile for 2nd call to f2 inside f1 - overheadA| ... - ---------- [2'w1] 1st call to get_time for 2nd f2 - overheadB| ... - ---------- start 2nd f2 - real 2' | ... - ---------- end 2nd f2 - overheadC| ... - ---------- [2'w2] 2nd call to get_time for 2nd f2 - overheadD| ... - ---------- end profile for f2 - real 1 | ... - ---------- end f1 - overheadC| ... ----------- [1w1'] 2nd call to get_time for f1 -overheadD| ... ----------- end profile for f1 - -When profiling f2, overheadB + overheadC should be subtracted from measure -and overheadA + overheadB + overheadC + overheadD should be subtracted from -the amount for f1 - -Then the relevant overheads are : - - "overheadB + overheadC" to be subtracted to the measure of f as many time as f is called and - - "overheadA + overheadB + overheadC + overheadD" to be subtracted to - the measure of f as many time as f calls a profiled function (itself - included) -*) - -let dummy_last_alloc = ref 0.0 -let dummy_spent_alloc () = - let now = get_alloc () in - let before = !last_alloc in - last_alloc := now; - now -. before -let dummy_f x = x -let dummy_stack = ref [create_record ()] -let dummy_ov = 0 - -let loops = 10000 - -let time_overhead_A_D () = - let e = create_record () in - let before = get_time () in - 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::_ -> - 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 dt = get_time () - 1 in - e.tottime <- dt + dummy_ov; e.owntime <- e.owntime + e.tottime; - ajoute_ownalloc p dw; - ajoute_totalloc p dw; - p.owntime <- p.owntime - e.tottime; - 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 !dummy_stack with [] -> assert false | _::s -> stack := s); - dummy_last_alloc := get_alloc () - done; - let after = get_time () in - let beforeloop = get_time () in - for _i = 1 to loops do () done; - let afterloop = get_time () in - float_of_int ((after - before) - (afterloop - beforeloop)) - /. float_of_int loops - -let time_overhead_B_C () = - let dummy_x = 0 in - let before = get_time () in - 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 CErrors.noncritical e -> assert false - done; - let after = get_time () in - let beforeloop = get_time () in - for _i = 1 to loops do () done; - let afterloop = get_time () in - float_of_int ((after - before) - (afterloop - beforeloop)) - /. float_of_int loops - -let compute_alloc lo = lo /. (float_of_int word_length) - -(************************************************) -(* End a profiling session and print the result *) - -let format_profile (table, outside, total) = - print_newline (); - Printf.printf - "%-23s %9s %9s %10s %10s %10s\n" - "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls "; - 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" - name - (float_of_time e.owntime) (float_of_time e.tottime) - (compute_alloc e.ownalloc) - (compute_alloc e.totalloc) - e.owncount e.intcount) - l; - Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f %6d\n" - "others" - (float_of_time outside.owntime) (float_of_time outside.tottime) - (compute_alloc outside.ownalloc) - (compute_alloc outside.totalloc) - outside.intcount; - (* Here, own contains overhead time/alloc *) - Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f\n" - "Est. overhead/total" - (float_of_time total.owntime) (float_of_time total.tottime) - (compute_alloc total.ownalloc) - (compute_alloc total.totalloc); - Printf.printf - "Time in seconds and allocation in words (1 word = %d bytes)\n" - word_length - -let recording_file = ref "" -let set_recording s = recording_file := s - -let adjust_time ov_bc ov_ad e = - let bc_imm = float_of_int e.owncount *. ov_bc in - let ad_imm = float_of_int e.immcount *. ov_ad in - let abcd_all = float_of_int e.intcount *. (ov_ad +. ov_bc) in - {e with - tottime = e.tottime - int_of_float (abcd_all +. bc_imm); - owntime = e.owntime - int_of_float (ad_imm +. bc_imm) } - -let close_profile print = - let dw = spent_alloc () in - let t = get_time () in - match !stack with - | [outside] -> - outside.tottime <- outside.tottime + t; - outside.owntime <- outside.owntime + t; - ajoute_ownalloc outside dw; - ajoute_totalloc outside dw; - if !prof_table <> [] then begin - let ov_bc = time_overhead_B_C () (* B+C overhead *) in - let ov_ad = time_overhead_A_D () (* A+D overhead *) in - let adjust (n,e) = (n, adjust_time ov_bc ov_ad e) in - let adjtable = List.map adjust !prof_table in - let adjoutside = adjust_time ov_bc ov_ad outside in - let totalloc = !last_alloc -. !init_alloc in - let total = create_record () in - total.tottime <- outside.tottime; - total.totalloc <- totalloc; - (* We compute estimations of overhead, put into "own" fields *) - total.owntime <- outside.tottime - adjoutside.tottime; - total.ownalloc <- totalloc -. outside.totalloc; - let current_data = (adjtable, adjoutside, total) in - let updated_data = - match !recording_file with - | "" -> current_data - | name -> merge_profile !recording_file current_data - in - if print then format_profile updated_data; - init_profile () - end - | _ -> failwith "Inconsistency" - -let print_profile () = close_profile true - -let declare_profile name = - if name = "___outside___" || name = "___total___" then - failwith ("Error: "^name^" is a reserved keyword"); - let e = create_record () in - prof_table := (name,e)::!prof_table; - e - -(* Default initialization, may be overridden *) -let _ = init_profile () - -(******************************) -(* Entry points for profiling *) -let profile1 e f a = - 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 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 profile2 e f a b = - 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 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 profile3 e f a b c = - 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 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 profile4 e f a b c d = - 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 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 profile5 e f a b c d g = - 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 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 profile6 e f a b c d g h = - 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 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 profile7 e f a b c d g h i = - 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 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 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) = 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) = 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 deleted file mode 100644 index 3328d7ea..00000000 --- a/lib/profile.mli +++ /dev/null @@ -1,119 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit - -val print_profile : unit -> unit -val reset_profile : unit -> unit -val init_profile : unit -> unit -val declare_profile : string -> profile_key - -val profile1 : profile_key -> ('a -> 'b) -> 'a -> 'b -val profile2 : profile_key -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c -val profile3 : - profile_key -> ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd -val profile4 : - profile_key -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e -val profile5 : - profile_key -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -val profile6 : - profile_key -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) - -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -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 - of ML objects *) - -(** Print logical size (in words) and depth of its argument - This function does not disturb the heap *) -val print_logical_stats : 'a -> unit - -(** Print physical size, logical size (in words) and depth of its argument - This function allocates itself a lot (the same order of magnitude - as the physical size of its argument) *) -val print_stats : 'a -> unit diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml index e7646fb7..978b8b73 100644 --- a/lib/remoteCounter.ml +++ b/lib/remoteCounter.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a @@ -25,7 +27,7 @@ let new_counter ~name a ~incr ~build = (* - 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 - CErrors.anomaly(Pp.str"Slave processes must install remote counters"); + CErrors.anomaly(Pp.str"Slave processes must install remote counters."); Mutex.lock m; let x = f () in Mutex.unlock m; build x in let mk_thsafe_remote_getter f () = @@ -33,7 +35,7 @@ let new_counter ~name a ~incr ~build = let getter = ref(mk_thsafe_local_getter (fun () -> !data := incr !!data; !!data)) in let installer f = if not (Flags.async_proofs_is_worker ()) then - CErrors.anomaly(Pp.str"Only slave processes can install a remote counter"); + CErrors.anomaly(Pp.str"Only slave processes can install a remote counter."); getter := mk_thsafe_remote_getter f in (fun () -> !getter ()), installer diff --git a/lib/remoteCounter.mli b/lib/remoteCounter.mli index 1b0fa6a0..ae0605cf 100644 --- a/lib/remoteCounter.mli +++ b/lib/remoteCounter.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false - | Node (node, child, pos, ctx) -> - let data = Buffer.contents pp_buffer in - let () = Buffer.clear pp_buffer in - let () = context.stack <- Node (node, PCData data :: child, pos, ctx) in - context.offset <- context.offset + len - in - - let open_xml_tag tag = - let () = push_pcdata () in - context.stack <- Node (tag, [], context.offset, context.stack) - in - - let close_xml_tag tag = - let () = push_pcdata () in - match context.stack with - | Leaf -> assert false - | Node (node, child, pos, ctx) -> - let () = assert (String.equal tag node) in - let annotation = - try Int.Map.find (int_of_string node) context.annotations - with _ -> None - in - let annotation = { - annotation = annotation; - startpos = pos; - endpos = context.offset; - } in - let xml = Element (node, annotation, List.rev child) in - match ctx with - | Leaf -> - (** Final node: we keep the result in a dummy context *) - context.stack <- Node ("", [xml], 0, Leaf) - | Node (node, child, pos, ctx) -> - context.stack <- Node (node, xml :: child, pos, ctx) - in - - let open Format in - - let ft = formatter_of_buffer pp_buffer in - - let tag_functions = { - mark_open_tag = (fun tag -> let () = open_xml_tag tag in ""); - mark_close_tag = (fun tag -> let () = close_xml_tag tag in ""); - print_open_tag = ignore; - print_close_tag = ignore; - } in - - pp_set_formatter_tag_functions ft tag_functions; - pp_set_mark_tags ft true; - - (** The whole output must be a valid document. To that - end, we nest the document inside tags. *) - pp_open_tag ft "pp"; - Pp.(pp_with ~pp_tag ft ppcmds); - pp_close_tag ft (); - - (** Get the resulting XML tree. *) - let () = pp_print_flush ft () in - let () = assert (Buffer.length pp_buffer = 0) in - match context.stack with - | Node ("", [xml], 0, Leaf) -> xml - | _ -> assert false - - -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 - -type richpp = xml - -let repr xml = xml -let richpp_of_xml xml = xml -let richpp_of_string s = PCData s - -let richpp_of_pp pp = - let annotate t = match Pp.Tag.prj t Ppstyle.tag with - | None -> None - | Some key -> Some (Ppstyle.repr key) - in - let rec drop = function - | PCData s -> [PCData s] - | Element (_, annotation, cs) -> - let cs = List.concat (List.map drop cs) in - match annotation.annotation with - | None -> cs - | Some s -> [Element (String.concat "." s, [], cs)] - in - let xml = rich_pp annotate pp in - Element ("_", [], drop xml) - -let raw_print xml = - let buf = Buffer.create 1024 in - let rec print = function - | PCData s -> Buffer.add_string buf s - | Element (_, _, cs) -> List.iter print cs - in - let () = print xml in - Buffer.contents buf - diff --git a/lib/richpp.mli b/lib/richpp.mli deleted file mode 100644 index 287d265a..00000000 --- a/lib/richpp.mli +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'annotation option) -> Pp.std_ppcmds -> - '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 - -(** {5 Enriched text} *) - -type richpp -(** Type of text with style annotations *) - -val richpp_of_pp : Pp.std_ppcmds -> richpp -(** Extract style information from formatted text *) - -val richpp_of_xml : Xml_datatype.xml -> richpp -(** Do not use outside of dedicated areas *) - -val richpp_of_string : string -> richpp -(** Make a styled text out of a normal string *) - -val repr : richpp -> Xml_datatype.xml -(** Observe the styled text as XML *) - -(** {5 Debug/Compat} *) - -(** Represent the semi-structured document as a string, dropping any additional - information. *) -val raw_print : richpp -> string diff --git a/lib/rtree.ml b/lib/rtree.ml index f89b98c0..0e371025 100644 --- a/lib/rtree.ml +++ b/lib/rtree.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'b) -> 'a t -> 'b t val smartmap : ('a -> 'a) -> 'a t -> 'a t (** A rather simple minded pretty-printer *) -val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds +val pp_tree : ('a -> Pp.t) -> 'a t -> Pp.t val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** @deprecated Same as [Rtree.equal] *) diff --git a/lib/segmenttree.ml b/lib/segmenttree.ml deleted file mode 100644 index 9ce348a0..00000000 --- a/lib/segmenttree.ml +++ /dev/null @@ -1,130 +0,0 @@ -(** This module is a very simple implementation of "segment trees". - - A segment tree of type ['a t] represents a mapping from a union of - disjoint segments to some values of type 'a. -*) - -(** Misc. functions. *) -let list_iteri f l = - let rec loop i = function - | [] -> () - | x :: xs -> f i x; loop (i + 1) xs - in - loop 0 l - -let log2 x = log x /. log 2. - -let log2n x = int_of_float (ceil (log2 (float_of_int x))) - -(** We focus on integers but this module can be generalized. *) -type elt = int - -(** A value of type [domain] is interpreted differently given its position - in the tree. On internal nodes, a domain represents the set of - integers which are _not_ in the set of keys handled by the tree. On - leaves, a domain represents the st of integers which are in the set of - keys. *) -type domain = - (** On internal nodes, a domain [Interval (a, b)] represents - the interval [a + 1; b - 1]. On leaves, it represents [a; b]. - We always have [a] <= [b]. *) - | Interval of elt * elt - (** On internal node or root, a domain [Universe] represents all - the integers. When the tree is not a trivial root, - [Universe] has no interpretation on leaves. (The lookup - function should never reach the leaves.) *) - | Universe - -(** We use an array to store the almost complete tree. This array - contains at least one element. *) -type 'a t = (domain * 'a option) array - -(** The root is the first item of the array. *) - -(** Standard layout for left child. *) -let left_child i = 2 * i + 1 - -(** Standard layout for right child. *) -let right_child i = 2 * i + 2 - -(** Extract the annotation of a node, be it internal or a leaf. *) -let value_of i t = match t.(i) with (_, Some x) -> x | _ -> raise Not_found - -(** Initialize the array to store [n] leaves. *) -let create n init = - Array.make (1 lsl (log2n n + 1) - 1) init - -(** Make a complete interval tree from a list of disjoint segments. - Precondition : the segments must be sorted. *) -let make segments = - let nsegments = List.length segments in - let tree = create nsegments (Universe, None) in - let leaves_offset = (1 lsl (log2n nsegments)) - 1 in - - (** The algorithm proceeds in two steps using an intermediate tree - to store minimum and maximum of each subtree as annotation of - the node. *) - - (** We start from leaves: the last level of the tree is initialized - with the given segments... *) - list_iteri - (fun i ((start, stop), value) -> - let k = leaves_offset + i in - let i = Interval (start, stop) in - tree.(k) <- (i, Some i)) - segments; - (** ... the remaining leaves are initialized with neutral information. *) - for k = leaves_offset + nsegments to Array.length tree -1 do - tree.(k) <- (Universe, Some Universe) - done; - - (** We traverse the tree bottom-up and compute the interval and - annotation associated to each node from the annotations of its - children. *) - for k = leaves_offset - 1 downto 0 do - let node, annotation = - match value_of (left_child k) tree, value_of (right_child k) tree with - | Interval (left_min, left_max), Interval (right_min, right_max) -> - (Interval (left_max, right_min), Interval (left_min, right_max)) - | Interval (min, max), Universe -> - (Interval (max, max), Interval (min, max)) - | Universe, Universe -> Universe, Universe - | Universe, _ -> assert false - in - tree.(k) <- (node, Some annotation) - done; - - (** Finally, annotation are replaced with the image related to each leaf. *) - let final_tree = - Array.mapi (fun i (segment, value) -> (segment, None)) tree - in - list_iteri - (fun i ((start, stop), value) -> - final_tree.(leaves_offset + i) - <- (Interval (start, stop), Some value)) - segments; - final_tree - -(** [lookup k t] looks for an image for key [k] in the interval tree [t]. - Raise [Not_found] if it fails. *) -let lookup k t = - let i = ref 0 in - while (snd t.(!i) = None) do - match fst t.(!i) with - | Interval (start, stop) -> - if k <= start then i := left_child !i - else if k >= stop then i:= right_child !i - else raise Not_found - | Universe -> raise Not_found - done; - match fst t.(!i) with - | Interval (start, stop) -> - if k >= start && k <= stop then - match snd t.(!i) with - | Some v -> v - | None -> assert false - else - raise Not_found - | Universe -> assert false - - diff --git a/lib/segmenttree.mli b/lib/segmenttree.mli deleted file mode 100644 index 3258537b..00000000 --- a/lib/segmenttree.mli +++ /dev/null @@ -1,20 +0,0 @@ -(** This module is a very simple implementation of "segment trees". - - A segment tree of type ['a t] represents a mapping from a union of - disjoint segments to some values of type 'a. -*) - -(** A mapping from a union of disjoint segments to some values of type ['a]. *) -type 'a t - -(** [make [(i1, j1), v1; (i2, j2), v2; ...]] creates a mapping that - associates to every integer [x] the value [v1] if [i1 <= x <= j1], - [v2] if [i2 <= x <= j2], and so one. - Precondition: the segments must be sorted. *) -val make : ((int * int) * 'a) list -> 'a t - -(** [lookup k t] looks for an image for key [k] in the interval tree [t]. - Raise [Not_found] if it fails. *) -val lookup : int -> 'a t -> 'a - - diff --git a/lib/spawn.ml b/lib/spawn.ml index 47917697..63e9e452 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -1,14 +1,16 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* prerr_endline ("kill: "^Printexc.to_string e) end let stats { oob_req; oob_resp; alive } = - assert_ alive "This process is dead"; + assert_ alive "This process is dead."; output_value oob_req ReqStats; flush oob_req; let RespStats g = input_value oob_resp in g diff --git a/lib/spawn.mli b/lib/spawn.mli index 9b86b095..c7a56349 100644 --- a/lib/spawn.mli +++ b/lib/spawn.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 - -module Make (M : T) : S = -struct - - let next = - let count = ref 0 in fun () -> - let n = !count in - incr count; - n - - 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 = [||] - -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 deleted file mode 100644 index 8eab314e..00000000 --- a/lib/store.mli +++ /dev/null @@ -1,46 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* '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 4b99de70..dfede29e 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (* in batch mode, we are not yet sure the directory exists *) - if !Flags.batch_mode && not (exists_dir dir) then StrSet.empty, true + if !trust_file_cache && not (exists_dir dir) then StrSet.empty, true else cache_dir dir, true in StrSet.mem bf contents || not fresh && @@ -80,7 +85,7 @@ let file_exists_respecting_case path f = let df = Filename.dirname f in (String.equal df "." || aux df) && exists_in_dir_respecting_case (Filename.concat path df) bf - in (!Flags.batch_mode || Sys.file_exists (Filename.concat path f)) && aux f + in (!trust_file_cache || Sys.file_exists (Filename.concat path f)) && aux f let rec search paths test = match paths with @@ -131,7 +136,7 @@ let find_file_in_path ?(warn=true) paths filename = let root = Filename.dirname filename in root, filename else - CErrors.errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else (* the name is considered to be the transcription as a relative @@ -139,7 +144,7 @@ let find_file_in_path ?(warn=true) paths filename = to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> - CErrors.errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ str "on loadpath")) @@ -162,7 +167,7 @@ let is_in_system_path filename = let open_trapping_failure name = try open_out_bin name with e when CErrors.noncritical e -> - CErrors.errorlabstrm "System.open" (str "Can't open " ++ str name) + CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name) let warn_cannot_remove_file = CWarnings.create ~name:"cannot-remove-file" ~category:"filesystem" @@ -174,7 +179,7 @@ let try_remove filename = warn_cannot_remove_file filename let error_corrupted file s = - CErrors.errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") + CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") let input_binary_int f ch = try input_binary_int ch @@ -251,7 +256,7 @@ let extern_state magic filename val_0 = let () = try_remove filename in iraise reraise with Sys_error s -> - CErrors.errorlabstrm "System.extern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.extern_state" (str "System error: " ++ str s) let intern_state magic filename = try @@ -260,12 +265,12 @@ let intern_state magic filename = close_in channel; v with Sys_error s -> - CErrors.errorlabstrm "System.intern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.intern_state" (str "System error: " ++ str s) let with_magic_number_check f a = try f a with Bad_magic_number {filename=fname;actual=actual;expected=expected} -> - CErrors.errorlabstrm "with_magic_number_check" + CErrors.user_err ~hdr:"with_magic_number_check" (str"File " ++ str fname ++ strbrk" has bad magic number " ++ int actual ++ str" (expected " ++ int expected ++ str")." ++ spc () ++ @@ -292,23 +297,18 @@ let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) = real (round (sstop -. sstart)) ++ str "s" ++ str ")" -let with_time time f x = +let with_time ~batch f x = let tstart = get_time() in - let msg = if time then "" else "Finished transaction in " in + let msg = if batch 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 + let msg2 = if batch then "" else " (successful)" in Feedback.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 + let msg = if batch then "" else "Finished failing transaction in " in + let msg2 = if batch then "" else " (failure)" in Feedback.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 21436909..3349dfea 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* CUnix.load_path -> string -> CUnix.physical_path * string +val trust_file_cache : bool ref +(** [trust_file_cache] indicates whether we trust the underlying + mapped file-system not to change along the execution of Coq. This + assumption greatly speds up file search, but it is often + inconvenient in interactive mode *) + val file_exists_respecting_case : string -> string -> bool (** {6 I/O functions } *) @@ -96,9 +104,6 @@ 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 +val fmt_time_difference : time -> time -> Pp.t -(** {6 Name of current process.} *) -val process_id : unit -> string +val with_time : batch:bool -> ('a -> 'b) -> 'a -> 'b diff --git a/lib/terminal.ml b/lib/terminal.ml deleted file mode 100644 index de21f102..00000000 --- a/lib/terminal.ml +++ /dev/null @@ -1,288 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 repr 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 - fg @ bg @ bold @ italic @ underline @ negative - -let eval st = - let tags = repr st 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 && Sys.os_type = "Unix" - -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 deleted file mode 100644 index e0fd7f22..00000000 --- a/lib/terminal.mli +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ?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 repr : style -> int list -(** Generate the ANSI code representing the given style. *) - -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 deleted file mode 100644 index 0309fde9..00000000 --- a/lib/trie.ml +++ /dev/null @@ -1,89 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 deleted file mode 100644 index de67e8f9..00000000 --- a/lib/trie.mli +++ /dev/null @@ -1,61 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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/unicode.ml b/lib/unicode.ml deleted file mode 100644 index ced5e258..00000000 --- a/lib/unicode.ml +++ /dev/null @@ -1,331 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 *) - | Unknown -> 0 lsl ((i land 7) lsl 1) (* 00 *) - -(* 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 Unknown - -(* [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 - -(* If [s] is some UTF-8 encoded string - and [i] is a position of some UTF-8 character within [s] - then [next_utf8 s i] returns [(j,n)] where: - - [j] indicates the position of the next UTF-8 character - - [n] represents the UTF-8 character at index [i] *) -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 () - -let is_utf8 s = - let rec check i = - let (off, _) = next_utf8 s i in - check (i + off) - in - try check 0 with End_of_input -> true | Invalid_argument _ -> false - -(* 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.") - | 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 = - let len = String.length s in - let has_UU i = - i+2 < len && s.[i]='_' && s.[i+1]='U' && s.[i+2]='U' - in - let i = ref 0 in - while !i < len && Char.code s.[!i] < 128 && not (has_UU !i) do - incr i - done; - if !i = len then s else - let out = Buffer.create (2*len) in - Buffer.add_substring out s 0 !i; - while !i < len do - let j, n = next_utf8 s !i in - if n >= 128 then - (Printf.bprintf out "_UU%04x_" n; i := !i + j) - else if has_UU !i then - (Buffer.add_string out "_UUU"; i := !i + 3) - else - (Buffer.add_char out s.[!i]; incr i) - done; - Buffer.contents out - -(* 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 *) - -(** FIXME: duplicate code with Pp *) - -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 - -(* Variant of String.sub for UTF8 character positions *) -let utf8_sub s start_u len_u = - let len_b = String.length s - and end_u = start_u + len_u - and cnt = ref 0 - and nc = ref 0 - and p = ref 0 in - let start_b = ref len_b in - while !p < len_b && !cnt < end_u do - if !cnt <= start_u then start_b := !p ; - 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_b && !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 ; - let end_b = !p in - String.sub s !start_b (end_b - !start_b) diff --git a/lib/unicode.mli b/lib/unicode.mli deleted file mode 100644 index 2609e196..00000000 --- a/lib/unicode.mli +++ /dev/null @@ -1,42 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* status - -(** Return [None] if a given string can be used as a (Coq) identifier. - Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. *) -val ident_refutation : string -> (bool * string) option - -(** First char of a string, converted to lowercase - @raise Assert_failure if the input string is empty. *) -val lowercase_first_char : string -> string - -(** Return [true] if all UTF-8 characters in the input string are just plain - ASCII characters. Returns [false] otherwise. *) -val is_basic_ascii : string -> bool - -(** [ascii_of_ident s] maps UTF-8 string to a string composed solely from ASCII - characters. The non-ASCII characters are translated to ["_UUxxxx_"] where - {i xxxx} is the Unicode index of the character in hexadecimal (from four - to six hex digits). To avoid potential name clashes, any preexisting - substring ["_UU"] is turned into ["_UUU"]. *) -val ascii_of_ident : string -> string - -(** Validate an UTF-8 string *) -val is_utf8 : string -> bool - -(** Return the length of a valid UTF-8 string. *) -val utf8_length : string -> int - -(** Variant of {!String.sub} for UTF-8 strings. *) -val utf8_sub : string -> int -> int -> string diff --git a/lib/unicodetable.ml b/lib/unicodetable.ml deleted file mode 100644 index f4e978d6..00000000 --- a/lib/unicodetable.ml +++ /dev/null @@ -1,2619 +0,0 @@ - -(** Unicode tables generated from Camomile. *) - -(* Letter, Uppercase *) -let lu = [ - (0x00041,0x0005A); - (0x000C0,0x000D6); - (0x000D8,0x000DE); - (0x00100,0x00100); - (0x00102,0x00102); - (0x00104,0x00104); - (0x00106,0x00106); - (0x00108,0x00108); - (0x0010A,0x0010A); - (0x0010C,0x0010C); - (0x0010E,0x0010E); - (0x00110,0x00110); - (0x00112,0x00112); - (0x00114,0x00114); - (0x00116,0x00116); - (0x00118,0x00118); - (0x0011A,0x0011A); - (0x0011C,0x0011C); - (0x0011E,0x0011E); - (0x00120,0x00120); - (0x00122,0x00122); - (0x00124,0x00124); - (0x00126,0x00126); - (0x00128,0x00128); - (0x0012A,0x0012A); - (0x0012C,0x0012C); - (0x0012E,0x0012E); - (0x00130,0x00130); - (0x00132,0x00132); - (0x00134,0x00134); - (0x00136,0x00136); - (0x00139,0x00139); - (0x0013B,0x0013B); - (0x0013D,0x0013D); - (0x0013F,0x0013F); - (0x00141,0x00141); - (0x00143,0x00143); - (0x00145,0x00145); - (0x00147,0x00147); - (0x0014A,0x0014A); - (0x0014C,0x0014C); - (0x0014E,0x0014E); - (0x00150,0x00150); - (0x00152,0x00152); - (0x00154,0x00154); - (0x00156,0x00156); - (0x00158,0x00158); - (0x0015A,0x0015A); - (0x0015C,0x0015C); - (0x0015E,0x0015E); - (0x00160,0x00160); - (0x00162,0x00162); - (0x00164,0x00164); - (0x00166,0x00166); - (0x00168,0x00168); - (0x0016A,0x0016A); - (0x0016C,0x0016C); - (0x0016E,0x0016E); - (0x00170,0x00170); - (0x00172,0x00172); - (0x00174,0x00174); - (0x00176,0x00176); - (0x00178,0x00179); - (0x0017B,0x0017B); - (0x0017D,0x0017D); - (0x00181,0x00182); - (0x00184,0x00184); - (0x00186,0x00187); - (0x00189,0x0018B); - (0x0018E,0x00191); - (0x00193,0x00194); - (0x00196,0x00198); - (0x0019C,0x0019D); - (0x0019F,0x001A0); - (0x001A2,0x001A2); - (0x001A4,0x001A4); - (0x001A6,0x001A7); - (0x001A9,0x001A9); - (0x001AC,0x001AC); - (0x001AE,0x001AF); - (0x001B1,0x001B3); - (0x001B5,0x001B5); - (0x001B7,0x001B8); - (0x001BC,0x001BC); - (0x001C4,0x001C4); - (0x001C7,0x001C7); - (0x001CA,0x001CA); - (0x001CD,0x001CD); - (0x001CF,0x001CF); - (0x001D1,0x001D1); - (0x001D3,0x001D3); - (0x001D5,0x001D5); - (0x001D7,0x001D7); - (0x001D9,0x001D9); - (0x001DB,0x001DB); - (0x001DE,0x001DE); - (0x001E0,0x001E0); - (0x001E2,0x001E2); - (0x001E4,0x001E4); - (0x001E6,0x001E6); - (0x001E8,0x001E8); - (0x001EA,0x001EA); - (0x001EC,0x001EC); - (0x001EE,0x001EE); - (0x001F1,0x001F1); - (0x001F4,0x001F4); - (0x001F6,0x001F8); - (0x001FA,0x001FA); - (0x001FC,0x001FC); - (0x001FE,0x001FE); - (0x00200,0x00200); - (0x00202,0x00202); - (0x00204,0x00204); - (0x00206,0x00206); - (0x00208,0x00208); - (0x0020A,0x0020A); - (0x0020C,0x0020C); - (0x0020E,0x0020E); - (0x00210,0x00210); - (0x00212,0x00212); - (0x00214,0x00214); - (0x00216,0x00216); - (0x00218,0x00218); - (0x0021A,0x0021A); - (0x0021C,0x0021C); - (0x0021E,0x0021E); - (0x00220,0x00220); - (0x00222,0x00222); - (0x00224,0x00224); - (0x00226,0x00226); - (0x00228,0x00228); - (0x0022A,0x0022A); - (0x0022C,0x0022C); - (0x0022E,0x0022E); - (0x00230,0x00230); - (0x00232,0x00232); - (0x00386,0x00386); - (0x00388,0x0038A); - (0x0038C,0x0038C); - (0x0038E,0x0038F); - (0x00391,0x003A1); - (0x003A3,0x003AB); - (0x003D2,0x003D4); - (0x003D8,0x003D8); - (0x003DA,0x003DA); - (0x003DC,0x003DC); - (0x003DE,0x003DE); - (0x003E0,0x003E0); - (0x003E2,0x003E2); - (0x003E4,0x003E4); - (0x003E6,0x003E6); - (0x003E8,0x003E8); - (0x003EA,0x003EA); - (0x003EC,0x003EC); - (0x003EE,0x003EE); - (0x003F4,0x003F4); - (0x00400,0x0042F); - (0x00460,0x00460); - (0x00462,0x00462); - (0x00464,0x00464); - (0x00466,0x00466); - (0x00468,0x00468); - (0x0046A,0x0046A); - (0x0046C,0x0046C); - (0x0046E,0x0046E); - (0x00470,0x00470); - (0x00472,0x00472); - (0x00474,0x00474); - (0x00476,0x00476); - (0x00478,0x00478); - (0x0047A,0x0047A); - (0x0047C,0x0047C); - (0x0047E,0x0047E); - (0x00480,0x00480); - (0x0048A,0x0048A); - (0x0048C,0x0048C); - (0x0048E,0x0048E); - (0x00490,0x00490); - (0x00492,0x00492); - (0x00494,0x00494); - (0x00496,0x00496); - (0x00498,0x00498); - (0x0049A,0x0049A); - (0x0049C,0x0049C); - (0x0049E,0x0049E); - (0x004A0,0x004A0); - (0x004A2,0x004A2); - (0x004A4,0x004A4); - (0x004A6,0x004A6); - (0x004A8,0x004A8); - (0x004AA,0x004AA); - (0x004AC,0x004AC); - (0x004AE,0x004AE); - (0x004B0,0x004B0); - (0x004B2,0x004B2); - (0x004B4,0x004B4); - (0x004B6,0x004B6); - (0x004B8,0x004B8); - (0x004BA,0x004BA); - (0x004BC,0x004BC); - (0x004BE,0x004BE); - (0x004C0,0x004C1); - (0x004C3,0x004C3); - (0x004C5,0x004C5); - (0x004C7,0x004C7); - (0x004C9,0x004C9); - (0x004CB,0x004CB); - (0x004CD,0x004CD); - (0x004D0,0x004D0); - (0x004D2,0x004D2); - (0x004D4,0x004D4); - (0x004D6,0x004D6); - (0x004D8,0x004D8); - (0x004DA,0x004DA); - (0x004DC,0x004DC); - (0x004DE,0x004DE); - (0x004E0,0x004E0); - (0x004E2,0x004E2); - (0x004E4,0x004E4); - (0x004E6,0x004E6); - (0x004E8,0x004E8); - (0x004EA,0x004EA); - (0x004EC,0x004EC); - (0x004EE,0x004EE); - (0x004F0,0x004F0); - (0x004F2,0x004F2); - (0x004F4,0x004F4); - (0x004F8,0x004F8); - (0x00500,0x00500); - (0x00502,0x00502); - (0x00504,0x00504); - (0x00506,0x00506); - (0x00508,0x00508); - (0x0050A,0x0050A); - (0x0050C,0x0050C); - (0x0050E,0x0050E); - (0x00531,0x00556); - (0x010A0,0x010C5); - (0x01E00,0x01E00); - (0x01E02,0x01E02); - (0x01E04,0x01E04); - (0x01E06,0x01E06); - (0x01E08,0x01E08); - (0x01E0A,0x01E0A); - (0x01E0C,0x01E0C); - (0x01E0E,0x01E0E); - (0x01E10,0x01E10); - (0x01E12,0x01E12); - (0x01E14,0x01E14); - (0x01E16,0x01E16); - (0x01E18,0x01E18); - (0x01E1A,0x01E1A); - (0x01E1C,0x01E1C); - (0x01E1E,0x01E1E); - (0x01E20,0x01E20); - (0x01E22,0x01E22); - (0x01E24,0x01E24); - (0x01E26,0x01E26); - (0x01E28,0x01E28); - (0x01E2A,0x01E2A); - (0x01E2C,0x01E2C); - (0x01E2E,0x01E2E); - (0x01E30,0x01E30); - (0x01E32,0x01E32); - (0x01E34,0x01E34); - (0x01E36,0x01E36); - (0x01E38,0x01E38); - (0x01E3A,0x01E3A); - (0x01E3C,0x01E3C); - (0x01E3E,0x01E3E); - (0x01E40,0x01E40); - (0x01E42,0x01E42); - (0x01E44,0x01E44); - (0x01E46,0x01E46); - (0x01E48,0x01E48); - (0x01E4A,0x01E4A); - (0x01E4C,0x01E4C); - (0x01E4E,0x01E4E); - (0x01E50,0x01E50); - (0x01E52,0x01E52); - (0x01E54,0x01E54); - (0x01E56,0x01E56); - (0x01E58,0x01E58); - (0x01E5A,0x01E5A); - (0x01E5C,0x01E5C); - (0x01E5E,0x01E5E); - (0x01E60,0x01E60); - (0x01E62,0x01E62); - (0x01E64,0x01E64); - (0x01E66,0x01E66); - (0x01E68,0x01E68); - (0x01E6A,0x01E6A); - (0x01E6C,0x01E6C); - (0x01E6E,0x01E6E); - (0x01E70,0x01E70); - (0x01E72,0x01E72); - (0x01E74,0x01E74); - (0x01E76,0x01E76); - (0x01E78,0x01E78); - (0x01E7A,0x01E7A); - (0x01E7C,0x01E7C); - (0x01E7E,0x01E7E); - (0x01E80,0x01E80); - (0x01E82,0x01E82); - (0x01E84,0x01E84); - (0x01E86,0x01E86); - (0x01E88,0x01E88); - (0x01E8A,0x01E8A); - (0x01E8C,0x01E8C); - (0x01E8E,0x01E8E); - (0x01E90,0x01E90); - (0x01E92,0x01E92); - (0x01E94,0x01E94); - (0x01EA0,0x01EA0); - (0x01EA2,0x01EA2); - (0x01EA4,0x01EA4); - (0x01EA6,0x01EA6); - (0x01EA8,0x01EA8); - (0x01EAA,0x01EAA); - (0x01EAC,0x01EAC); - (0x01EAE,0x01EAE); - (0x01EB0,0x01EB0); - (0x01EB2,0x01EB2); - (0x01EB4,0x01EB4); - (0x01EB6,0x01EB6); - (0x01EB8,0x01EB8); - (0x01EBA,0x01EBA); - (0x01EBC,0x01EBC); - (0x01EBE,0x01EBE); - (0x01EC0,0x01EC0); - (0x01EC2,0x01EC2); - (0x01EC4,0x01EC4); - (0x01EC6,0x01EC6); - (0x01EC8,0x01EC8); - (0x01ECA,0x01ECA); - (0x01ECC,0x01ECC); - (0x01ECE,0x01ECE); - (0x01ED0,0x01ED0); - (0x01ED2,0x01ED2); - (0x01ED4,0x01ED4); - (0x01ED6,0x01ED6); - (0x01ED8,0x01ED8); - (0x01EDA,0x01EDA); - (0x01EDC,0x01EDC); - (0x01EDE,0x01EDE); - (0x01EE0,0x01EE0); - (0x01EE2,0x01EE2); - (0x01EE4,0x01EE4); - (0x01EE6,0x01EE6); - (0x01EE8,0x01EE8); - (0x01EEA,0x01EEA); - (0x01EEC,0x01EEC); - (0x01EEE,0x01EEE); - (0x01EF0,0x01EF0); - (0x01EF2,0x01EF2); - (0x01EF4,0x01EF4); - (0x01EF6,0x01EF6); - (0x01EF8,0x01EF8); - (0x01F08,0x01F0F); - (0x01F18,0x01F1D); - (0x01F28,0x01F2F); - (0x01F38,0x01F3F); - (0x01F48,0x01F4D); - (0x01F59,0x01F59); - (0x01F5B,0x01F5B); - (0x01F5D,0x01F5D); - (0x01F5F,0x01F5F); - (0x01F68,0x01F6F); - (0x01FB8,0x01FBB); - (0x01FC8,0x01FCB); - (0x01FD8,0x01FDB); - (0x01FE8,0x01FEC); - (0x01FF8,0x01FFB); - (0x02102,0x02102); - (0x02107,0x02107); - (0x0210B,0x0210D); - (0x02110,0x02112); - (0x02115,0x02115); - (0x02119,0x0211D); - (0x02124,0x02124); - (0x02126,0x02126); - (0x02128,0x02128); - (0x0212A,0x0212D); - (0x02130,0x02131); - (0x02133,0x02133); - (0x0213E,0x0213F); - (0x02145,0x02145); - (0x0FF21,0x0FF3A); - (0x10400,0x10425); - (0x1D400,0x1D419); - (0x1D434,0x1D44D); - (0x1D468,0x1D481); - (0x1D49C,0x1D49C); - (0x1D49E,0x1D49F); - (0x1D4A2,0x1D4A2); - (0x1D4A5,0x1D4A6); - (0x1D4A9,0x1D4AC); - (0x1D4AE,0x1D4B5); - (0x1D4D0,0x1D4E9); - (0x1D504,0x1D505); - (0x1D507,0x1D50A); - (0x1D50D,0x1D514); - (0x1D516,0x1D51C); - (0x1D538,0x1D539); - (0x1D53B,0x1D53E); - (0x1D540,0x1D544); - (0x1D546,0x1D546); - (0x1D54A,0x1D550); - (0x1D56C,0x1D585); - (0x1D5A0,0x1D5B9); - (0x1D5D4,0x1D5ED); - (0x1D608,0x1D621); - (0x1D63C,0x1D655); - (0x1D670,0x1D689); - (0x1D6A8,0x1D6C0); - (0x1D6E2,0x1D6FA); - (0x1D71C,0x1D734); - (0x1D756,0x1D76E); - (0x1D790,0x1D7A8) -] -(* Letter, Lowercase *) -let ll = [ - (0x00061,0x0007A); - (0x000AA,0x000AA); - (0x000B5,0x000B5); - (0x000BA,0x000BA); - (0x000DF,0x000F6); - (0x000F8,0x000FF); - (0x00101,0x00101); - (0x00103,0x00103); - (0x00105,0x00105); - (0x00107,0x00107); - (0x00109,0x00109); - (0x0010B,0x0010B); - (0x0010D,0x0010D); - (0x0010F,0x0010F); - (0x00111,0x00111); - (0x00113,0x00113); - (0x00115,0x00115); - (0x00117,0x00117); - (0x00119,0x00119); - (0x0011B,0x0011B); - (0x0011D,0x0011D); - (0x0011F,0x0011F); - (0x00121,0x00121); - (0x00123,0x00123); - (0x00125,0x00125); - (0x00127,0x00127); - (0x00129,0x00129); - (0x0012B,0x0012B); - (0x0012D,0x0012D); - (0x0012F,0x0012F); - (0x00131,0x00131); - (0x00133,0x00133); - (0x00135,0x00135); - (0x00137,0x00138); - (0x0013A,0x0013A); - (0x0013C,0x0013C); - (0x0013E,0x0013E); - (0x00140,0x00140); - (0x00142,0x00142); - (0x00144,0x00144); - (0x00146,0x00146); - (0x00148,0x00149); - (0x0014B,0x0014B); - (0x0014D,0x0014D); - (0x0014F,0x0014F); - (0x00151,0x00151); - (0x00153,0x00153); - (0x00155,0x00155); - (0x00157,0x00157); - (0x00159,0x00159); - (0x0015B,0x0015B); - (0x0015D,0x0015D); - (0x0015F,0x0015F); - (0x00161,0x00161); - (0x00163,0x00163); - (0x00165,0x00165); - (0x00167,0x00167); - (0x00169,0x00169); - (0x0016B,0x0016B); - (0x0016D,0x0016D); - (0x0016F,0x0016F); - (0x00171,0x00171); - (0x00173,0x00173); - (0x00175,0x00175); - (0x00177,0x00177); - (0x0017A,0x0017A); - (0x0017C,0x0017C); - (0x0017E,0x00180); - (0x00183,0x00183); - (0x00185,0x00185); - (0x00188,0x00188); - (0x0018C,0x0018D); - (0x00192,0x00192); - (0x00195,0x00195); - (0x00199,0x0019B); - (0x0019E,0x0019E); - (0x001A1,0x001A1); - (0x001A3,0x001A3); - (0x001A5,0x001A5); - (0x001A8,0x001A8); - (0x001AA,0x001AB); - (0x001AD,0x001AD); - (0x001B0,0x001B0); - (0x001B4,0x001B4); - (0x001B6,0x001B6); - (0x001B9,0x001BA); - (0x001BD,0x001BF); - (0x001C6,0x001C6); - (0x001C9,0x001C9); - (0x001CC,0x001CC); - (0x001CE,0x001CE); - (0x001D0,0x001D0); - (0x001D2,0x001D2); - (0x001D4,0x001D4); - (0x001D6,0x001D6); - (0x001D8,0x001D8); - (0x001DA,0x001DA); - (0x001DC,0x001DD); - (0x001DF,0x001DF); - (0x001E1,0x001E1); - (0x001E3,0x001E3); - (0x001E5,0x001E5); - (0x001E7,0x001E7); - (0x001E9,0x001E9); - (0x001EB,0x001EB); - (0x001ED,0x001ED); - (0x001EF,0x001F0); - (0x001F3,0x001F3); - (0x001F5,0x001F5); - (0x001F9,0x001F9); - (0x001FB,0x001FB); - (0x001FD,0x001FD); - (0x001FF,0x001FF); - (0x00201,0x00201); - (0x00203,0x00203); - (0x00205,0x00205); - (0x00207,0x00207); - (0x00209,0x00209); - (0x0020B,0x0020B); - (0x0020D,0x0020D); - (0x0020F,0x0020F); - (0x00211,0x00211); - (0x00213,0x00213); - (0x00215,0x00215); - (0x00217,0x00217); - (0x00219,0x00219); - (0x0021B,0x0021B); - (0x0021D,0x0021D); - (0x0021F,0x0021F); - (0x00223,0x00223); - (0x00225,0x00225); - (0x00227,0x00227); - (0x00229,0x00229); - (0x0022B,0x0022B); - (0x0022D,0x0022D); - (0x0022F,0x0022F); - (0x00231,0x00231); - (0x00233,0x00233); - (0x00250,0x002AD); - (0x00390,0x00390); - (0x003AC,0x003CE); - (0x003D0,0x003D1); - (0x003D5,0x003D7); - (0x003D9,0x003D9); - (0x003DB,0x003DB); - (0x003DD,0x003DD); - (0x003DF,0x003DF); - (0x003E1,0x003E1); - (0x003E3,0x003E3); - (0x003E5,0x003E5); - (0x003E7,0x003E7); - (0x003E9,0x003E9); - (0x003EB,0x003EB); - (0x003ED,0x003ED); - (0x003EF,0x003F3); - (0x003F5,0x003F5); - (0x00430,0x0045F); - (0x00461,0x00461); - (0x00463,0x00463); - (0x00465,0x00465); - (0x00467,0x00467); - (0x00469,0x00469); - (0x0046B,0x0046B); - (0x0046D,0x0046D); - (0x0046F,0x0046F); - (0x00471,0x00471); - (0x00473,0x00473); - (0x00475,0x00475); - (0x00477,0x00477); - (0x00479,0x00479); - (0x0047B,0x0047B); - (0x0047D,0x0047D); - (0x0047F,0x0047F); - (0x00481,0x00481); - (0x0048B,0x0048B); - (0x0048D,0x0048D); - (0x0048F,0x0048F); - (0x00491,0x00491); - (0x00493,0x00493); - (0x00495,0x00495); - (0x00497,0x00497); - (0x00499,0x00499); - (0x0049B,0x0049B); - (0x0049D,0x0049D); - (0x0049F,0x0049F); - (0x004A1,0x004A1); - (0x004A3,0x004A3); - (0x004A5,0x004A5); - (0x004A7,0x004A7); - (0x004A9,0x004A9); - (0x004AB,0x004AB); - (0x004AD,0x004AD); - (0x004AF,0x004AF); - (0x004B1,0x004B1); - (0x004B3,0x004B3); - (0x004B5,0x004B5); - (0x004B7,0x004B7); - (0x004B9,0x004B9); - (0x004BB,0x004BB); - (0x004BD,0x004BD); - (0x004BF,0x004BF); - (0x004C2,0x004C2); - (0x004C4,0x004C4); - (0x004C6,0x004C6); - (0x004C8,0x004C8); - (0x004CA,0x004CA); - (0x004CC,0x004CC); - (0x004CE,0x004CE); - (0x004D1,0x004D1); - (0x004D3,0x004D3); - (0x004D5,0x004D5); - (0x004D7,0x004D7); - (0x004D9,0x004D9); - (0x004DB,0x004DB); - (0x004DD,0x004DD); - (0x004DF,0x004DF); - (0x004E1,0x004E1); - (0x004E3,0x004E3); - (0x004E5,0x004E5); - (0x004E7,0x004E7); - (0x004E9,0x004E9); - (0x004EB,0x004EB); - (0x004ED,0x004ED); - (0x004EF,0x004EF); - (0x004F1,0x004F1); - (0x004F3,0x004F3); - (0x004F5,0x004F5); - (0x004F9,0x004F9); - (0x00501,0x00501); - (0x00503,0x00503); - (0x00505,0x00505); - (0x00507,0x00507); - (0x00509,0x00509); - (0x0050B,0x0050B); - (0x0050D,0x0050D); - (0x0050F,0x0050F); - (0x00561,0x00587); - (0x01E01,0x01E01); - (0x01E03,0x01E03); - (0x01E05,0x01E05); - (0x01E07,0x01E07); - (0x01E09,0x01E09); - (0x01E0B,0x01E0B); - (0x01E0D,0x01E0D); - (0x01E0F,0x01E0F); - (0x01E11,0x01E11); - (0x01E13,0x01E13); - (0x01E15,0x01E15); - (0x01E17,0x01E17); - (0x01E19,0x01E19); - (0x01E1B,0x01E1B); - (0x01E1D,0x01E1D); - (0x01E1F,0x01E1F); - (0x01E21,0x01E21); - (0x01E23,0x01E23); - (0x01E25,0x01E25); - (0x01E27,0x01E27); - (0x01E29,0x01E29); - (0x01E2B,0x01E2B); - (0x01E2D,0x01E2D); - (0x01E2F,0x01E2F); - (0x01E31,0x01E31); - (0x01E33,0x01E33); - (0x01E35,0x01E35); - (0x01E37,0x01E37); - (0x01E39,0x01E39); - (0x01E3B,0x01E3B); - (0x01E3D,0x01E3D); - (0x01E3F,0x01E3F); - (0x01E41,0x01E41); - (0x01E43,0x01E43); - (0x01E45,0x01E45); - (0x01E47,0x01E47); - (0x01E49,0x01E49); - (0x01E4B,0x01E4B); - (0x01E4D,0x01E4D); - (0x01E4F,0x01E4F); - (0x01E51,0x01E51); - (0x01E53,0x01E53); - (0x01E55,0x01E55); - (0x01E57,0x01E57); - (0x01E59,0x01E59); - (0x01E5B,0x01E5B); - (0x01E5D,0x01E5D); - (0x01E5F,0x01E5F); - (0x01E61,0x01E61); - (0x01E63,0x01E63); - (0x01E65,0x01E65); - (0x01E67,0x01E67); - (0x01E69,0x01E69); - (0x01E6B,0x01E6B); - (0x01E6D,0x01E6D); - (0x01E6F,0x01E6F); - (0x01E71,0x01E71); - (0x01E73,0x01E73); - (0x01E75,0x01E75); - (0x01E77,0x01E77); - (0x01E79,0x01E79); - (0x01E7B,0x01E7B); - (0x01E7D,0x01E7D); - (0x01E7F,0x01E7F); - (0x01E81,0x01E81); - (0x01E83,0x01E83); - (0x01E85,0x01E85); - (0x01E87,0x01E87); - (0x01E89,0x01E89); - (0x01E8B,0x01E8B); - (0x01E8D,0x01E8D); - (0x01E8F,0x01E8F); - (0x01E91,0x01E91); - (0x01E93,0x01E93); - (0x01E95,0x01E9B); - (0x01EA1,0x01EA1); - (0x01EA3,0x01EA3); - (0x01EA5,0x01EA5); - (0x01EA7,0x01EA7); - (0x01EA9,0x01EA9); - (0x01EAB,0x01EAB); - (0x01EAD,0x01EAD); - (0x01EAF,0x01EAF); - (0x01EB1,0x01EB1); - (0x01EB3,0x01EB3); - (0x01EB5,0x01EB5); - (0x01EB7,0x01EB7); - (0x01EB9,0x01EB9); - (0x01EBB,0x01EBB); - (0x01EBD,0x01EBD); - (0x01EBF,0x01EBF); - (0x01EC1,0x01EC1); - (0x01EC3,0x01EC3); - (0x01EC5,0x01EC5); - (0x01EC7,0x01EC7); - (0x01EC9,0x01EC9); - (0x01ECB,0x01ECB); - (0x01ECD,0x01ECD); - (0x01ECF,0x01ECF); - (0x01ED1,0x01ED1); - (0x01ED3,0x01ED3); - (0x01ED5,0x01ED5); - (0x01ED7,0x01ED7); - (0x01ED9,0x01ED9); - (0x01EDB,0x01EDB); - (0x01EDD,0x01EDD); - (0x01EDF,0x01EDF); - (0x01EE1,0x01EE1); - (0x01EE3,0x01EE3); - (0x01EE5,0x01EE5); - (0x01EE7,0x01EE7); - (0x01EE9,0x01EE9); - (0x01EEB,0x01EEB); - (0x01EED,0x01EED); - (0x01EEF,0x01EEF); - (0x01EF1,0x01EF1); - (0x01EF3,0x01EF3); - (0x01EF5,0x01EF5); - (0x01EF7,0x01EF7); - (0x01EF9,0x01EF9); - (0x01F00,0x01F07); - (0x01F10,0x01F15); - (0x01F20,0x01F27); - (0x01F30,0x01F37); - (0x01F40,0x01F45); - (0x01F50,0x01F57); - (0x01F60,0x01F67); - (0x01F70,0x01F7D); - (0x01F80,0x01F87); - (0x01F90,0x01F97); - (0x01FA0,0x01FA7); - (0x01FB0,0x01FB4); - (0x01FB6,0x01FB7); - (0x01FBE,0x01FBE); - (0x01FC2,0x01FC4); - (0x01FC6,0x01FC7); - (0x01FD0,0x01FD3); - (0x01FD6,0x01FD7); - (0x01FE0,0x01FE7); - (0x01FF2,0x01FF4); - (0x01FF6,0x01FF7); - (0x02071,0x02071); - (0x0207F,0x0207F); - (0x0210A,0x0210A); - (0x0210E,0x0210F); - (0x02113,0x02113); - (0x0212F,0x0212F); - (0x02134,0x02134); - (0x02139,0x02139); - (0x0213D,0x0213D); - (0x02146,0x02149); - (0x0FB00,0x0FB06); - (0x0FB13,0x0FB17); - (0x0FF41,0x0FF5A); - (0x10428,0x1044D); - (0x1D41A,0x1D433); - (0x1D44E,0x1D454); - (0x1D456,0x1D467); - (0x1D482,0x1D49B); - (0x1D4B6,0x1D4B9); - (0x1D4BB,0x1D4BB); - (0x1D4BD,0x1D4C0); - (0x1D4C2,0x1D4C3); - (0x1D4C5,0x1D4CF); - (0x1D4EA,0x1D503); - (0x1D51E,0x1D537); - (0x1D552,0x1D56B); - (0x1D586,0x1D59F); - (0x1D5BA,0x1D5D3); - (0x1D5EE,0x1D607); - (0x1D622,0x1D63B); - (0x1D656,0x1D66F); - (0x1D68A,0x1D6A3); - (0x1D6C2,0x1D6DA); - (0x1D6DC,0x1D6E1); - (0x1D6FC,0x1D714); - (0x1D716,0x1D71B); - (0x1D736,0x1D74E); - (0x1D750,0x1D755); - (0x1D770,0x1D788); - (0x1D78A,0x1D78F); - (0x1D7AA,0x1D7C2); - (0x1D7C4,0x1D7C9) -] -(* Letter, Titlecase *) -let lt = [ - (0x001C5,0x001C5); - (0x001C8,0x001C8); - (0x001CB,0x001CB); - (0x001F2,0x001F2); - (0x01F88,0x01F8F); - (0x01F98,0x01F9F); - (0x01FA8,0x01FAF); - (0x01FBC,0x01FBC); - (0x01FCC,0x01FCC); - (0x01FFC,0x01FFC) -] -(* Mark, Non-Spacing *) -let mn = [ - (0x00300,0x0034F); - (0x00360,0x0036F); - (0x00483,0x00486); - (0x00591,0x005A1); - (0x005A3,0x005B9); - (0x005BB,0x005BD); - (0x005BF,0x005BF); - (0x005C1,0x005C2); - (0x005C4,0x005C4); - (0x0064B,0x00655); - (0x00670,0x00670); - (0x006D6,0x006DC); - (0x006DF,0x006E4); - (0x006E7,0x006E8); - (0x006EA,0x006ED); - (0x00711,0x00711); - (0x00730,0x0074A); - (0x007A6,0x007B0); - (0x00901,0x00902); - (0x0093C,0x0093C); - (0x00941,0x00948); - (0x0094D,0x0094D); - (0x00951,0x00954); - (0x00962,0x00963); - (0x00981,0x00981); - (0x009BC,0x009BC); - (0x009C1,0x009C4); - (0x009CD,0x009CD); - (0x009E2,0x009E3); - (0x00A02,0x00A02); - (0x00A3C,0x00A3C); - (0x00A41,0x00A42); - (0x00A47,0x00A48); - (0x00A4B,0x00A4D); - (0x00A70,0x00A71); - (0x00A81,0x00A82); - (0x00ABC,0x00ABC); - (0x00AC1,0x00AC5); - (0x00AC7,0x00AC8); - (0x00ACD,0x00ACD); - (0x00B01,0x00B01); - (0x00B3C,0x00B3C); - (0x00B3F,0x00B3F); - (0x00B41,0x00B43); - (0x00B4D,0x00B4D); - (0x00B56,0x00B56); - (0x00B82,0x00B82); - (0x00BC0,0x00BC0); - (0x00BCD,0x00BCD); - (0x00C3E,0x00C40); - (0x00C46,0x00C48); - (0x00C4A,0x00C4D); - (0x00C55,0x00C56); - (0x00CBF,0x00CBF); - (0x00CC6,0x00CC6); - (0x00CCC,0x00CCD); - (0x00D41,0x00D43); - (0x00D4D,0x00D4D); - (0x00DCA,0x00DCA); - (0x00DD2,0x00DD4); - (0x00DD6,0x00DD6); - (0x00E31,0x00E31); - (0x00E34,0x00E3A); - (0x00E47,0x00E4E); - (0x00EB1,0x00EB1); - (0x00EB4,0x00EB9); - (0x00EBB,0x00EBC); - (0x00EC8,0x00ECD); - (0x00F18,0x00F19); - (0x00F35,0x00F35); - (0x00F37,0x00F37); - (0x00F39,0x00F39); - (0x00F71,0x00F7E); - (0x00F80,0x00F84); - (0x00F86,0x00F87); - (0x00F90,0x00F97); - (0x00F99,0x00FBC); - (0x00FC6,0x00FC6); - (0x0102D,0x01030); - (0x01032,0x01032); - (0x01036,0x01037); - (0x01039,0x01039); - (0x01058,0x01059); - (0x01712,0x01714); - (0x01732,0x01734); - (0x01752,0x01753); - (0x01772,0x01773); - (0x017B7,0x017BD); - (0x017C6,0x017C6); - (0x017C9,0x017D3); - (0x0180B,0x0180D); - (0x018A9,0x018A9); - (0x020D0,0x020DC); - (0x020E1,0x020E1); - (0x020E5,0x020EA); - (0x0302A,0x0302F); - (0x03099,0x0309A); - (0x0FB1E,0x0FB1E); - (0x0FE00,0x0FE0F); - (0x0FE20,0x0FE23); - (0x1D167,0x1D169); - (0x1D17B,0x1D182); - (0x1D185,0x1D18B); - (0x1D1AA,0x1D1AD) -] -(* Mark, Spacing Combining *) -let mc = [ - (0x00903,0x00903); - (0x0093E,0x00940); - (0x00949,0x0094C); - (0x00982,0x00983); - (0x009BE,0x009C0); - (0x009C7,0x009C8); - (0x009CB,0x009CC); - (0x009D7,0x009D7); - (0x00A3E,0x00A40); - (0x00A83,0x00A83); - (0x00ABE,0x00AC0); - (0x00AC9,0x00AC9); - (0x00ACB,0x00ACC); - (0x00B02,0x00B03); - (0x00B3E,0x00B3E); - (0x00B40,0x00B40); - (0x00B47,0x00B48); - (0x00B4B,0x00B4C); - (0x00B57,0x00B57); - (0x00BBE,0x00BBF); - (0x00BC1,0x00BC2); - (0x00BC6,0x00BC8); - (0x00BCA,0x00BCC); - (0x00BD7,0x00BD7); - (0x00C01,0x00C03); - (0x00C41,0x00C44); - (0x00C82,0x00C83); - (0x00CBE,0x00CBE); - (0x00CC0,0x00CC4); - (0x00CC7,0x00CC8); - (0x00CCA,0x00CCB); - (0x00CD5,0x00CD6); - (0x00D02,0x00D03); - (0x00D3E,0x00D40); - (0x00D46,0x00D48); - (0x00D4A,0x00D4C); - (0x00D57,0x00D57); - (0x00D82,0x00D83); - (0x00DCF,0x00DD1); - (0x00DD8,0x00DDF); - (0x00DF2,0x00DF3); - (0x00F3E,0x00F3F); - (0x00F7F,0x00F7F); - (0x0102C,0x0102C); - (0x01031,0x01031); - (0x01038,0x01038); - (0x01056,0x01057); - (0x017B4,0x017B6); - (0x017BE,0x017C5); - (0x017C7,0x017C8); - (0x1D165,0x1D166); - (0x1D16D,0x1D172) -] -(* Mark, Enclosing *) -let me = [ - (0x00488,0x00489); - (0x006DE,0x006DE); - (0x020DD,0x020E0); - (0x020E2,0x020E4) -] -(* Number, Decimal Digit *) -let nd = [ - (0x00030,0x00039); - (0x00660,0x00669); - (0x006F0,0x006F9); - (0x00966,0x0096F); - (0x009E6,0x009EF); - (0x00A66,0x00A6F); - (0x00AE6,0x00AEF); - (0x00B66,0x00B6F); - (0x00BE7,0x00BEF); - (0x00C66,0x00C6F); - (0x00CE6,0x00CEF); - (0x00D66,0x00D6F); - (0x00E50,0x00E59); - (0x00ED0,0x00ED9); - (0x00F20,0x00F29); - (0x01040,0x01049); - (0x01369,0x01371); - (0x017E0,0x017E9); - (0x01810,0x01819); - (0x0FF10,0x0FF19); - (0x1D7CE,0x1D7FF) -] -(* Number, Letter *) -let nl = [ - (0x016EE,0x016F0); - (0x02160,0x02183); - (0x03007,0x03007); - (0x03021,0x03029); - (0x03038,0x0303A); - (0x1034A,0x1034A) -] -(* Number, Other *) -let no = [ - (0x000B2,0x000B3); - (0x000B9,0x000B9); - (0x000BC,0x000BE); - (0x009F4,0x009F9); - (0x00BF0,0x00BF2); - (0x00F2A,0x00F33); - (0x01372,0x0137C); - (0x02070,0x02070); - (0x02074,0x02079); - (0x02080,0x02089); - (0x02153,0x0215F); - (0x02460,0x0249B); - (0x024EA,0x024FE); - (0x02776,0x02793); - (0x03192,0x03195); - (0x03220,0x03229); - (0x03251,0x0325F); - (0x03280,0x03289); - (0x032B1,0x032BF); - (0x10320,0x10323) -] -(* Separator, Space *) -let zs = [ - (0x00020,0x00020); - (0x000A0,0x000A0); - (0x01680,0x01680); - (0x02000,0x0200B); - (0x0202F,0x0202F); - (0x0205F,0x0205F); - (0x03000,0x03000) -] -(* Separator, Line *) -let zl = [ - (0x02028,0x02028) -] -(* Separator, Paragraph *) -let zp = [ - (0x02029,0x02029) -] -(* Other, Control *) -let cc = [ - (0x00000,0x0001F); - (0x0007F,0x0009F) -] -(* Other, Format *) -let cf = [ - (0x006DD,0x006DD); - (0x0070F,0x0070F); - (0x0180E,0x0180E); - (0x0200C,0x0200F); - (0x0202A,0x0202E); - (0x02060,0x02063); - (0x0206A,0x0206F); - (0x0FEFF,0x0FEFF); - (0x0FFF9,0x0FFFB); - (0x1D173,0x1D17A); - (0xE0001,0xE0001); - (0xE0020,0xE007F) -] -(* Other, Surrogate *) -let cs = [ - (0x0D800,0x0DEFE); - (0x0DFFF,0x0DFFF) -] -(* Other, Private Use *) -let co = [ - (0x0E000,0x0F8FF) -] -(* Other, Not Assigned *) -let cn = [ - (0x00221,0x00221); - (0x00234,0x0024F); - (0x002AE,0x002AF); - (0x002EF,0x002FF); - (0x00350,0x0035F); - (0x00370,0x00373); - (0x00376,0x00379); - (0x0037B,0x0037D); - (0x0037F,0x00383); - (0x0038B,0x0038B); - (0x0038D,0x0038D); - (0x003A2,0x003A2); - (0x003CF,0x003CF); - (0x003F7,0x003FF); - (0x00487,0x00487); - (0x004CF,0x004CF); - (0x004F6,0x004F7); - (0x004FA,0x004FF); - (0x00510,0x00530); - (0x00557,0x00558); - (0x00560,0x00560); - (0x00588,0x00588); - (0x0058B,0x00590); - (0x005A2,0x005A2); - (0x005BA,0x005BA); - (0x005C5,0x005CF); - (0x005EB,0x005EF); - (0x005F5,0x0060B); - (0x0060D,0x0061A); - (0x0061C,0x0061E); - (0x00620,0x00620); - (0x0063B,0x0063F); - (0x00656,0x0065F); - (0x006EE,0x006EF); - (0x006FF,0x006FF); - (0x0070E,0x0070E); - (0x0072D,0x0072F); - (0x0074B,0x0077F); - (0x007B2,0x00900); - (0x00904,0x00904); - (0x0093A,0x0093B); - (0x0094E,0x0094F); - (0x00955,0x00957); - (0x00971,0x00980); - (0x00984,0x00984); - (0x0098D,0x0098E); - (0x00991,0x00992); - (0x009A9,0x009A9); - (0x009B1,0x009B1); - (0x009B3,0x009B5); - (0x009BA,0x009BB); - (0x009BD,0x009BD); - (0x009C5,0x009C6); - (0x009C9,0x009CA); - (0x009CE,0x009D6); - (0x009D8,0x009DB); - (0x009DE,0x009DE); - (0x009E4,0x009E5); - (0x009FB,0x00A01); - (0x00A03,0x00A04); - (0x00A0B,0x00A0E); - (0x00A11,0x00A12); - (0x00A29,0x00A29); - (0x00A31,0x00A31); - (0x00A34,0x00A34); - (0x00A37,0x00A37); - (0x00A3A,0x00A3B); - (0x00A3D,0x00A3D); - (0x00A43,0x00A46); - (0x00A49,0x00A4A); - (0x00A4E,0x00A58); - (0x00A5D,0x00A5D); - (0x00A5F,0x00A65); - (0x00A75,0x00A80); - (0x00A84,0x00A84); - (0x00A8C,0x00A8C); - (0x00A8E,0x00A8E); - (0x00A92,0x00A92); - (0x00AA9,0x00AA9); - (0x00AB1,0x00AB1); - (0x00AB4,0x00AB4); - (0x00ABA,0x00ABB); - (0x00AC6,0x00AC6); - (0x00ACA,0x00ACA); - (0x00ACE,0x00ACF); - (0x00AD1,0x00ADF); - (0x00AE1,0x00AE5); - (0x00AF0,0x00B00); - (0x00B04,0x00B04); - (0x00B0D,0x00B0E); - (0x00B11,0x00B12); - (0x00B29,0x00B29); - (0x00B31,0x00B31); - (0x00B34,0x00B35); - (0x00B3A,0x00B3B); - (0x00B44,0x00B46); - (0x00B49,0x00B4A); - (0x00B4E,0x00B55); - (0x00B58,0x00B5B); - (0x00B5E,0x00B5E); - (0x00B62,0x00B65); - (0x00B71,0x00B81); - (0x00B84,0x00B84); - (0x00B8B,0x00B8D); - (0x00B91,0x00B91); - (0x00B96,0x00B98); - (0x00B9B,0x00B9B); - (0x00B9D,0x00B9D); - (0x00BA0,0x00BA2); - (0x00BA5,0x00BA7); - (0x00BAB,0x00BAD); - (0x00BB6,0x00BB6); - (0x00BBA,0x00BBD); - (0x00BC3,0x00BC5); - (0x00BC9,0x00BC9); - (0x00BCE,0x00BD6); - (0x00BD8,0x00BE6); - (0x00BF3,0x00C00); - (0x00C04,0x00C04); - (0x00C0D,0x00C0D); - (0x00C11,0x00C11); - (0x00C29,0x00C29); - (0x00C34,0x00C34); - (0x00C3A,0x00C3D); - (0x00C45,0x00C45); - (0x00C49,0x00C49); - (0x00C4E,0x00C54); - (0x00C57,0x00C5F); - (0x00C62,0x00C65); - (0x00C70,0x00C81); - (0x00C84,0x00C84); - (0x00C8D,0x00C8D); - (0x00C91,0x00C91); - (0x00CA9,0x00CA9); - (0x00CB4,0x00CB4); - (0x00CBA,0x00CBD); - (0x00CC5,0x00CC5); - (0x00CC9,0x00CC9); - (0x00CCE,0x00CD4); - (0x00CD7,0x00CDD); - (0x00CDF,0x00CDF); - (0x00CE2,0x00CE5); - (0x00CF0,0x00D01); - (0x00D04,0x00D04); - (0x00D0D,0x00D0D); - (0x00D11,0x00D11); - (0x00D29,0x00D29); - (0x00D3A,0x00D3D); - (0x00D44,0x00D45); - (0x00D49,0x00D49); - (0x00D4E,0x00D56); - (0x00D58,0x00D5F); - (0x00D62,0x00D65); - (0x00D70,0x00D81); - (0x00D84,0x00D84); - (0x00D97,0x00D99); - (0x00DB2,0x00DB2); - (0x00DBC,0x00DBC); - (0x00DBE,0x00DBF); - (0x00DC7,0x00DC9); - (0x00DCB,0x00DCE); - (0x00DD5,0x00DD5); - (0x00DD7,0x00DD7); - (0x00DE0,0x00DF1); - (0x00DF5,0x00E00); - (0x00E3B,0x00E3E); - (0x00E5C,0x00E80); - (0x00E83,0x00E83); - (0x00E85,0x00E86); - (0x00E89,0x00E89); - (0x00E8B,0x00E8C); - (0x00E8E,0x00E93); - (0x00E98,0x00E98); - (0x00EA0,0x00EA0); - (0x00EA4,0x00EA4); - (0x00EA6,0x00EA6); - (0x00EA8,0x00EA9); - (0x00EAC,0x00EAC); - (0x00EBA,0x00EBA); - (0x00EBE,0x00EBF); - (0x00EC5,0x00EC5); - (0x00EC7,0x00EC7); - (0x00ECE,0x00ECF); - (0x00EDA,0x00EDB); - (0x00EDE,0x00EFF); - (0x00F48,0x00F48); - (0x00F6B,0x00F70); - (0x00F8C,0x00F8F); - (0x00F98,0x00F98); - (0x00FBD,0x00FBD); - (0x00FCD,0x00FCE); - (0x00FD0,0x00FFF); - (0x01022,0x01022); - (0x01028,0x01028); - (0x0102B,0x0102B); - (0x01033,0x01035); - (0x0103A,0x0103F); - (0x0105A,0x0109F); - (0x010C6,0x010CF); - (0x010F9,0x010FA); - (0x010FC,0x010FF); - (0x0115A,0x0115E); - (0x011A3,0x011A7); - (0x011FA,0x011FF); - (0x01207,0x01207); - (0x01247,0x01247); - (0x01249,0x01249); - (0x0124E,0x0124F); - (0x01257,0x01257); - (0x01259,0x01259); - (0x0125E,0x0125F); - (0x01287,0x01287); - (0x01289,0x01289); - (0x0128E,0x0128F); - (0x012AF,0x012AF); - (0x012B1,0x012B1); - (0x012B6,0x012B7); - (0x012BF,0x012BF); - (0x012C1,0x012C1); - (0x012C6,0x012C7); - (0x012CF,0x012CF); - (0x012D7,0x012D7); - (0x012EF,0x012EF); - (0x0130F,0x0130F); - (0x01311,0x01311); - (0x01316,0x01317); - (0x0131F,0x0131F); - (0x01347,0x01347); - (0x0135B,0x01360); - (0x0137D,0x0139F); - (0x013F5,0x01400); - (0x01677,0x0167F); - (0x0169D,0x0169F); - (0x016F1,0x016FF); - (0x0170D,0x0170D); - (0x01715,0x0171F); - (0x01737,0x0173F); - (0x01754,0x0175F); - (0x0176D,0x0176D); - (0x01771,0x01771); - (0x01774,0x0177F); - (0x017DD,0x017DF); - (0x017EA,0x017FF); - (0x0180F,0x0180F); - (0x0181A,0x0181F); - (0x01878,0x0187F); - (0x018AA,0x01DFF); - (0x01E9C,0x01E9F); - (0x01EFA,0x01EFF); - (0x01F16,0x01F17); - (0x01F1E,0x01F1F); - (0x01F46,0x01F47); - (0x01F4E,0x01F4F); - (0x01F58,0x01F58); - (0x01F5A,0x01F5A); - (0x01F5C,0x01F5C); - (0x01F5E,0x01F5E); - (0x01F7E,0x01F7F); - (0x01FB5,0x01FB5); - (0x01FC5,0x01FC5); - (0x01FD4,0x01FD5); - (0x01FDC,0x01FDC); - (0x01FF0,0x01FF1); - (0x01FF5,0x01FF5); - (0x01FFF,0x01FFF); - (0x02053,0x02056); - (0x02058,0x0205E); - (0x02064,0x02069); - (0x02072,0x02073); - (0x0208F,0x0209F); - (0x020B2,0x020CF); - (0x020EB,0x020FF); - (0x0213B,0x0213C); - (0x0214C,0x02152); - (0x02184,0x0218F); - (0x023CF,0x023FF); - (0x02427,0x0243F); - (0x0244B,0x0245F); - (0x024FF,0x024FF); - (0x02614,0x02615); - (0x02618,0x02618); - (0x0267E,0x0267F); - (0x0268A,0x02700); - (0x02705,0x02705); - (0x0270A,0x0270B); - (0x02728,0x02728); - (0x0274C,0x0274C); - (0x0274E,0x0274E); - (0x02753,0x02755); - (0x02757,0x02757); - (0x0275F,0x02760); - (0x02795,0x02797); - (0x027B0,0x027B0); - (0x027BF,0x027CF); - (0x027EC,0x027EF); - (0x02B00,0x02E7F); - (0x02E9A,0x02E9A); - (0x02EF4,0x02EFF); - (0x02FD6,0x02FEF); - (0x02FFC,0x02FFF); - (0x03040,0x03040); - (0x03097,0x03098); - (0x03100,0x03104); - (0x0312D,0x03130); - (0x0318F,0x0318F); - (0x031B8,0x031EF); - (0x0321D,0x0321F); - (0x03244,0x03250); - (0x0327C,0x0327E); - (0x032CC,0x032CF); - (0x032FF,0x032FF); - (0x03377,0x0337A); - (0x033DE,0x033DF); - (0x033FF,0x033FF); - (0x04DB6,0x04DFF); - (0x09FA6,0x09FFF); - (0x0A48D,0x0A48F); - (0x0A4C7,0x0ABFF); - (0x0D7A4,0x0D7FF); - (0x0DEFF,0x0DFFE); - (0x0FA2E,0x0FA2F); - (0x0FA6B,0x0FAFF); - (0x0FB07,0x0FB12); - (0x0FB18,0x0FB1C); - (0x0FB37,0x0FB37); - (0x0FB3D,0x0FB3D); - (0x0FB3F,0x0FB3F); - (0x0FB42,0x0FB42); - (0x0FB45,0x0FB45); - (0x0FBB2,0x0FBD2); - (0x0FD40,0x0FD4F); - (0x0FD90,0x0FD91); - (0x0FDC8,0x0FDEF); - (0x0FDFD,0x0FDFF); - (0x0FE10,0x0FE1F); - (0x0FE24,0x0FE2F); - (0x0FE47,0x0FE48); - (0x0FE53,0x0FE53); - (0x0FE67,0x0FE67); - (0x0FE6C,0x0FE6F); - (0x0FE75,0x0FE75); - (0x0FEFD,0x0FEFE); - (0x0FF00,0x0FF00); - (0x0FFBF,0x0FFC1); - (0x0FFC8,0x0FFC9); - (0x0FFD0,0x0FFD1); - (0x0FFD8,0x0FFD9); - (0x0FFDD,0x0FFDF); - (0x0FFE7,0x0FFE7); - (0x0FFEF,0x0FFF8); - (0x0FFFE,0x102FF); - (0x1031F,0x1031F); - (0x10324,0x1032F); - (0x1034B,0x103FF); - (0x10426,0x10427); - (0x1044E,0x1CFFF); - (0x1D0F6,0x1D0FF); - (0x1D127,0x1D129); - (0x1D1DE,0x1D3FF); - (0x1D455,0x1D455); - (0x1D49D,0x1D49D); - (0x1D4A0,0x1D4A1); - (0x1D4A3,0x1D4A4); - (0x1D4A7,0x1D4A8); - (0x1D4AD,0x1D4AD); - (0x1D4BA,0x1D4BA); - (0x1D4BC,0x1D4BC); - (0x1D4C1,0x1D4C1); - (0x1D4C4,0x1D4C4); - (0x1D506,0x1D506); - (0x1D50B,0x1D50C); - (0x1D515,0x1D515); - (0x1D51D,0x1D51D); - (0x1D53A,0x1D53A); - (0x1D53F,0x1D53F); - (0x1D545,0x1D545); - (0x1D547,0x1D549); - (0x1D551,0x1D551); - (0x1D6A4,0x1D6A7); - (0x1D7CA,0x1D7CD); - (0x1D800,0x1FFFF); - (0x2A6D7,0x2F7FF); - (0x2FA1E,0xE0000); - (0xE0002,0xE001F); - (0xE0080,0x7FFFFFFF) -] -(* Letter, Modifier *) -let lm = [ - (0x002B0,0x002B8); - (0x002BB,0x002C1); - (0x002D0,0x002D1); - (0x002E0,0x002E4); - (0x002EE,0x002EE); - (0x0037A,0x0037A); - (0x00559,0x00559); - (0x00640,0x00640); - (0x006E5,0x006E6); - (0x00E46,0x00E46); - (0x00EC6,0x00EC6); - (0x017D7,0x017D7); - (0x01843,0x01843); - (0x03005,0x03005); - (0x03031,0x03035); - (0x0303B,0x0303B); - (0x0309D,0x0309E); - (0x030FC,0x030FE); - (0x0FF70,0x0FF70); - (0x0FF9E,0x0FF9F) -] -(* Letter, Other *) -let lo = [ - (0x001BB,0x001BB); - (0x001C0,0x001C3); - (0x005D0,0x005EA); - (0x005F0,0x005F2); - (0x00621,0x0063A); - (0x00641,0x0064A); - (0x0066E,0x0066F); - (0x00671,0x006D3); - (0x006D5,0x006D5); - (0x006FA,0x006FC); - (0x00710,0x00710); - (0x00712,0x0072C); - (0x00780,0x007A5); - (0x007B1,0x007B1); - (0x00905,0x00939); - (0x0093D,0x0093D); - (0x00950,0x00950); - (0x00958,0x00961); - (0x00985,0x0098C); - (0x0098F,0x00990); - (0x00993,0x009A8); - (0x009AA,0x009B0); - (0x009B2,0x009B2); - (0x009B6,0x009B9); - (0x009DC,0x009DD); - (0x009DF,0x009E1); - (0x009F0,0x009F1); - (0x00A05,0x00A0A); - (0x00A0F,0x00A10); - (0x00A13,0x00A28); - (0x00A2A,0x00A30); - (0x00A32,0x00A33); - (0x00A35,0x00A36); - (0x00A38,0x00A39); - (0x00A59,0x00A5C); - (0x00A5E,0x00A5E); - (0x00A72,0x00A74); - (0x00A85,0x00A8B); - (0x00A8D,0x00A8D); - (0x00A8F,0x00A91); - (0x00A93,0x00AA8); - (0x00AAA,0x00AB0); - (0x00AB2,0x00AB3); - (0x00AB5,0x00AB9); - (0x00ABD,0x00ABD); - (0x00AD0,0x00AD0); - (0x00AE0,0x00AE0); - (0x00B05,0x00B0C); - (0x00B0F,0x00B10); - (0x00B13,0x00B28); - (0x00B2A,0x00B30); - (0x00B32,0x00B33); - (0x00B36,0x00B39); - (0x00B3D,0x00B3D); - (0x00B5C,0x00B5D); - (0x00B5F,0x00B61); - (0x00B83,0x00B83); - (0x00B85,0x00B8A); - (0x00B8E,0x00B90); - (0x00B92,0x00B95); - (0x00B99,0x00B9A); - (0x00B9C,0x00B9C); - (0x00B9E,0x00B9F); - (0x00BA3,0x00BA4); - (0x00BA8,0x00BAA); - (0x00BAE,0x00BB5); - (0x00BB7,0x00BB9); - (0x00C05,0x00C0C); - (0x00C0E,0x00C10); - (0x00C12,0x00C28); - (0x00C2A,0x00C33); - (0x00C35,0x00C39); - (0x00C60,0x00C61); - (0x00C85,0x00C8C); - (0x00C8E,0x00C90); - (0x00C92,0x00CA8); - (0x00CAA,0x00CB3); - (0x00CB5,0x00CB9); - (0x00CDE,0x00CDE); - (0x00CE0,0x00CE1); - (0x00D05,0x00D0C); - (0x00D0E,0x00D10); - (0x00D12,0x00D28); - (0x00D2A,0x00D39); - (0x00D60,0x00D61); - (0x00D85,0x00D96); - (0x00D9A,0x00DB1); - (0x00DB3,0x00DBB); - (0x00DBD,0x00DBD); - (0x00DC0,0x00DC6); - (0x00E01,0x00E30); - (0x00E32,0x00E33); - (0x00E40,0x00E45); - (0x00E81,0x00E82); - (0x00E84,0x00E84); - (0x00E87,0x00E88); - (0x00E8A,0x00E8A); - (0x00E8D,0x00E8D); - (0x00E94,0x00E97); - (0x00E99,0x00E9F); - (0x00EA1,0x00EA3); - (0x00EA5,0x00EA5); - (0x00EA7,0x00EA7); - (0x00EAA,0x00EAB); - (0x00EAD,0x00EB0); - (0x00EB2,0x00EB3); - (0x00EBD,0x00EBD); - (0x00EC0,0x00EC4); - (0x00EDC,0x00EDD); - (0x00F00,0x00F00); - (0x00F40,0x00F47); - (0x00F49,0x00F6A); - (0x00F88,0x00F8B); - (0x01000,0x01021); - (0x01023,0x01027); - (0x01029,0x0102A); - (0x01050,0x01055); - (0x010D0,0x010F8); - (0x01100,0x01159); - (0x0115F,0x011A2); - (0x011A8,0x011F9); - (0x01200,0x01206); - (0x01208,0x01246); - (0x01248,0x01248); - (0x0124A,0x0124D); - (0x01250,0x01256); - (0x01258,0x01258); - (0x0125A,0x0125D); - (0x01260,0x01286); - (0x01288,0x01288); - (0x0128A,0x0128D); - (0x01290,0x012AE); - (0x012B0,0x012B0); - (0x012B2,0x012B5); - (0x012B8,0x012BE); - (0x012C0,0x012C0); - (0x012C2,0x012C5); - (0x012C8,0x012CE); - (0x012D0,0x012D6); - (0x012D8,0x012EE); - (0x012F0,0x0130E); - (0x01310,0x01310); - (0x01312,0x01315); - (0x01318,0x0131E); - (0x01320,0x01346); - (0x01348,0x0135A); - (0x013A0,0x013F4); - (0x01401,0x0166C); - (0x0166F,0x01676); - (0x01681,0x0169A); - (0x016A0,0x016EA); - (0x01700,0x0170C); - (0x0170E,0x01711); - (0x01720,0x01731); - (0x01740,0x01751); - (0x01760,0x0176C); - (0x0176E,0x01770); - (0x01780,0x017B3); - (0x017DC,0x017DC); - (0x01820,0x01842); - (0x01844,0x01877); - (0x01880,0x018A8); - (0x02135,0x02138); - (0x03006,0x03006); - (0x0303C,0x0303C); - (0x03041,0x03096); - (0x0309F,0x0309F); - (0x030A1,0x030FA); - (0x030FF,0x030FF); - (0x03105,0x0312C); - (0x03131,0x0318E); - (0x031A0,0x031B7); - (0x031F0,0x031FF); - (0x03400,0x04DB5); - (0x04E00,0x09FA5); - (0x0A000,0x0A48C); - (0x0AC00,0x0D7A3); - (0x0F900,0x0FA2D); - (0x0FA30,0x0FA6A); - (0x0FB1D,0x0FB1D); - (0x0FB1F,0x0FB28); - (0x0FB2A,0x0FB36); - (0x0FB38,0x0FB3C); - (0x0FB3E,0x0FB3E); - (0x0FB40,0x0FB41); - (0x0FB43,0x0FB44); - (0x0FB46,0x0FBB1); - (0x0FBD3,0x0FD3D); - (0x0FD50,0x0FD8F); - (0x0FD92,0x0FDC7); - (0x0FDF0,0x0FDFB); - (0x0FE70,0x0FE74); - (0x0FE76,0x0FEFC); - (0x0FF66,0x0FF6F); - (0x0FF71,0x0FF9D); - (0x0FFA0,0x0FFBE); - (0x0FFC2,0x0FFC7); - (0x0FFCA,0x0FFCF); - (0x0FFD2,0x0FFD7); - (0x0FFDA,0x0FFDC); - (0x10300,0x1031E); - (0x10330,0x10349); - (0x20000,0x2A6D6); - (0x2F800,0x2FA1D) -] -(* Punctuation, Connector *) -let pc = [ - (0x0005F,0x0005F); - (0x0203F,0x02040); - (0x030FB,0x030FB); - (0x0FE33,0x0FE34); - (0x0FE4D,0x0FE4F); - (0x0FF3F,0x0FF3F); - (0x0FF65,0x0FF65) -] -(* Punctuation, Dash *) -let pd = [ - (0x0002D,0x0002D); - (0x000AD,0x000AD); - (0x0058A,0x0058A); - (0x01806,0x01806); - (0x02010,0x02015); - (0x0301C,0x0301C); - (0x03030,0x03030); - (0x030A0,0x030A0); - (0x0FE31,0x0FE32); - (0x0FE58,0x0FE58); - (0x0FE63,0x0FE63); - (0x0FF0D,0x0FF0D) -] -(* Punctuation, Open *) -let ps = [ - (0x00028,0x00028); - (0x0005B,0x0005B); - (0x0007B,0x0007B); - (0x00F3A,0x00F3A); - (0x00F3C,0x00F3C); - (0x0169B,0x0169B); - (0x0201A,0x0201A); - (0x0201E,0x0201E); - (0x02045,0x02045); - (0x0207D,0x0207D); - (0x0208D,0x0208D); - (0x02329,0x02329); - (0x023B4,0x023B4); - (0x02768,0x02768); - (0x0276A,0x0276A); - (0x0276C,0x0276C); - (0x0276E,0x0276E); - (0x02770,0x02770); - (0x02772,0x02772); - (0x02774,0x02774); - (0x027E6,0x027E6); - (0x027E8,0x027E8); - (0x027EA,0x027EA); - (0x02983,0x02983); - (0x02985,0x02985); - (0x02987,0x02987); - (0x02989,0x02989); - (0x0298B,0x0298B); - (0x0298D,0x0298D); - (0x0298F,0x0298F); - (0x02991,0x02991); - (0x02993,0x02993); - (0x02995,0x02995); - (0x02997,0x02997); - (0x029D8,0x029D8); - (0x029DA,0x029DA); - (0x029FC,0x029FC); - (0x03008,0x03008); - (0x0300A,0x0300A); - (0x0300C,0x0300C); - (0x0300E,0x0300E); - (0x03010,0x03010); - (0x03014,0x03014); - (0x03016,0x03016); - (0x03018,0x03018); - (0x0301A,0x0301A); - (0x0301D,0x0301D); - (0x0FD3E,0x0FD3E); - (0x0FE35,0x0FE35); - (0x0FE37,0x0FE37); - (0x0FE39,0x0FE39); - (0x0FE3B,0x0FE3B); - (0x0FE3D,0x0FE3D); - (0x0FE3F,0x0FE3F); - (0x0FE41,0x0FE41); - (0x0FE43,0x0FE43); - (0x0FE59,0x0FE59); - (0x0FE5B,0x0FE5B); - (0x0FE5D,0x0FE5D); - (0x0FF08,0x0FF08); - (0x0FF3B,0x0FF3B); - (0x0FF5B,0x0FF5B); - (0x0FF5F,0x0FF5F); - (0x0FF62,0x0FF62) -] -(* Punctuation, Close *) -let pe = [ - (0x00029,0x00029); - (0x0005D,0x0005D); - (0x0007D,0x0007D); - (0x00F3B,0x00F3B); - (0x00F3D,0x00F3D); - (0x0169C,0x0169C); - (0x02046,0x02046); - (0x0207E,0x0207E); - (0x0208E,0x0208E); - (0x0232A,0x0232A); - (0x023B5,0x023B5); - (0x02769,0x02769); - (0x0276B,0x0276B); - (0x0276D,0x0276D); - (0x0276F,0x0276F); - (0x02771,0x02771); - (0x02773,0x02773); - (0x02775,0x02775); - (0x027E7,0x027E7); - (0x027E9,0x027E9); - (0x027EB,0x027EB); - (0x02984,0x02984); - (0x02986,0x02986); - (0x02988,0x02988); - (0x0298A,0x0298A); - (0x0298C,0x0298C); - (0x0298E,0x0298E); - (0x02990,0x02990); - (0x02992,0x02992); - (0x02994,0x02994); - (0x02996,0x02996); - (0x02998,0x02998); - (0x029D9,0x029D9); - (0x029DB,0x029DB); - (0x029FD,0x029FD); - (0x03009,0x03009); - (0x0300B,0x0300B); - (0x0300D,0x0300D); - (0x0300F,0x0300F); - (0x03011,0x03011); - (0x03015,0x03015); - (0x03017,0x03017); - (0x03019,0x03019); - (0x0301B,0x0301B); - (0x0301E,0x0301F); - (0x0FD3F,0x0FD3F); - (0x0FE36,0x0FE36); - (0x0FE38,0x0FE38); - (0x0FE3A,0x0FE3A); - (0x0FE3C,0x0FE3C); - (0x0FE3E,0x0FE3E); - (0x0FE40,0x0FE40); - (0x0FE42,0x0FE42); - (0x0FE44,0x0FE44); - (0x0FE5A,0x0FE5A); - (0x0FE5C,0x0FE5C); - (0x0FE5E,0x0FE5E); - (0x0FF09,0x0FF09); - (0x0FF3D,0x0FF3D); - (0x0FF5D,0x0FF5D); - (0x0FF60,0x0FF60); - (0x0FF63,0x0FF63) -] -(* Punctuation, Initial quote *) -let pi = [ - (0x000AB,0x000AB); - (0x02018,0x02018); - (0x0201B,0x0201C); - (0x0201F,0x0201F); - (0x02039,0x02039) -] -(* Punctuation, Final quote *) -let pf = [ - (0x000BB,0x000BB); - (0x02019,0x02019); - (0x0201D,0x0201D); - (0x0203A,0x0203A) -] -(* Punctuation, Other *) -let po = [ - (0x00021,0x00023); - (0x00025,0x00027); - (0x0002A,0x0002A); - (0x0002C,0x0002C); - (0x0002E,0x0002F); - (0x0003A,0x0003B); - (0x0003F,0x00040); - (0x0005C,0x0005C); - (0x000A1,0x000A1); - (0x000B7,0x000B7); - (0x000BF,0x000BF); - (0x0037E,0x0037E); - (0x00387,0x00387); - (0x0055A,0x0055F); - (0x00589,0x00589); - (0x005BE,0x005BE); - (0x005C0,0x005C0); - (0x005C3,0x005C3); - (0x005F3,0x005F4); - (0x0060C,0x0060C); - (0x0061B,0x0061B); - (0x0061F,0x0061F); - (0x0066A,0x0066D); - (0x006D4,0x006D4); - (0x00700,0x0070D); - (0x00964,0x00965); - (0x00970,0x00970); - (0x00DF4,0x00DF4); - (0x00E4F,0x00E4F); - (0x00E5A,0x00E5B); - (0x00F04,0x00F12); - (0x00F85,0x00F85); - (0x0104A,0x0104F); - (0x010FB,0x010FB); - (0x01361,0x01368); - (0x0166D,0x0166E); - (0x016EB,0x016ED); - (0x01735,0x01736); - (0x017D4,0x017D6); - (0x017D8,0x017DA); - (0x01800,0x01805); - (0x01807,0x0180A); - (0x02016,0x02017); - (0x02020,0x02027); - (0x02030,0x02038); - (0x0203B,0x0203E); - (0x02041,0x02043); - (0x02047,0x02051); - (0x02057,0x02057); - (0x023B6,0x023B6); - (0x03001,0x03003); - (0x0303D,0x0303D); - (0x0FE30,0x0FE30); - (0x0FE45,0x0FE46); - (0x0FE49,0x0FE4C); - (0x0FE50,0x0FE52); - (0x0FE54,0x0FE57); - (0x0FE5F,0x0FE61); - (0x0FE68,0x0FE68); - (0x0FE6A,0x0FE6B); - (0x0FF01,0x0FF03); - (0x0FF05,0x0FF07); - (0x0FF0A,0x0FF0A); - (0x0FF0C,0x0FF0C); - (0x0FF0E,0x0FF0F); - (0x0FF1A,0x0FF1B); - (0x0FF1F,0x0FF20); - (0x0FF3C,0x0FF3C); - (0x0FF61,0x0FF61); - (0x0FF64,0x0FF64) -] -(* Symbol, Math *) -let sm = [ - (0x0002B,0x0002B); - (0x0003C,0x0003E); - (0x0007C,0x0007C); - (0x0007E,0x0007E); - (0x000AC,0x000AC); - (0x000B1,0x000B1); - (0x000D7,0x000D7); - (0x000F7,0x000F7); - (0x003F6,0x003F6); - (0x02044,0x02044); - (0x02052,0x02052); - (0x0207A,0x0207C); - (0x0208A,0x0208C); - (0x02140,0x02144); - (0x0214B,0x0214B); - (0x02190,0x02194); - (0x0219A,0x0219B); - (0x021A0,0x021A0); - (0x021A3,0x021A3); - (0x021A6,0x021A6); - (0x021AE,0x021AE); - (0x021CE,0x021CF); - (0x021D2,0x021D2); - (0x021D4,0x021D4); - (0x021F4,0x022FF); - (0x02308,0x0230B); - (0x02320,0x02321); - (0x0237C,0x0237C); - (0x0239B,0x023B3); - (0x025B7,0x025B7); - (0x025C1,0x025C1); - (0x025F8,0x025FF); - (0x0266F,0x0266F); - (0x027D0,0x027E5); - (0x027F0,0x027FF); - (0x02900,0x02982); - (0x02999,0x029D7); - (0x029DC,0x029FB); - (0x029FE,0x02AFF); - (0x0FB29,0x0FB29); - (0x0FE62,0x0FE62); - (0x0FE64,0x0FE66); - (0x0FF0B,0x0FF0B); - (0x0FF1C,0x0FF1E); - (0x0FF5C,0x0FF5C); - (0x0FF5E,0x0FF5E); - (0x0FFE2,0x0FFE2); - (0x0FFE9,0x0FFEC); - (0x1D6C1,0x1D6C1); - (0x1D6DB,0x1D6DB); - (0x1D6FB,0x1D6FB); - (0x1D715,0x1D715); - (0x1D735,0x1D735); - (0x1D74F,0x1D74F); - (0x1D76F,0x1D76F); - (0x1D789,0x1D789); - (0x1D7A9,0x1D7A9); - (0x1D7C3,0x1D7C3) -] -(* Symbol, Currency *) -let sc = [ - (0x00024,0x00024); - (0x000A2,0x000A5); - (0x009F2,0x009F3); - (0x00E3F,0x00E3F); - (0x017DB,0x017DB); - (0x020A0,0x020B1); - (0x0FDFC,0x0FDFC); - (0x0FE69,0x0FE69); - (0x0FF04,0x0FF04); - (0x0FFE0,0x0FFE1); - (0x0FFE5,0x0FFE6) -] -(* Symbol, Modifier *) -let sk = [ - (0x0005E,0x0005E); - (0x00060,0x00060); - (0x000A8,0x000A8); - (0x000AF,0x000AF); - (0x000B4,0x000B4); - (0x000B8,0x000B8); - (0x002B9,0x002BA); - (0x002C2,0x002CF); - (0x002D2,0x002DF); - (0x002E5,0x002ED); - (0x00374,0x00375); - (0x00384,0x00385); - (0x01FBD,0x01FBD); - (0x01FBF,0x01FC1); - (0x01FCD,0x01FCF); - (0x01FDD,0x01FDF); - (0x01FED,0x01FEF); - (0x01FFD,0x01FFE); - (0x0309B,0x0309C); - (0x0FF3E,0x0FF3E); - (0x0FF40,0x0FF40); - (0x0FFE3,0x0FFE3) -] -(* Symbol, Other *) -let so = [ - (0x000A6,0x000A7); - (0x000A9,0x000A9); - (0x000AE,0x000AE); - (0x000B0,0x000B0); - (0x000B6,0x000B6); - (0x00482,0x00482); - (0x006E9,0x006E9); - (0x006FD,0x006FE); - (0x009FA,0x009FA); - (0x00B70,0x00B70); - (0x00F01,0x00F03); - (0x00F13,0x00F17); - (0x00F1A,0x00F1F); - (0x00F34,0x00F34); - (0x00F36,0x00F36); - (0x00F38,0x00F38); - (0x00FBE,0x00FC5); - (0x00FC7,0x00FCC); - (0x00FCF,0x00FCF); - (0x02100,0x02101); - (0x02103,0x02106); - (0x02108,0x02109); - (0x02114,0x02114); - (0x02116,0x02118); - (0x0211E,0x02123); - (0x02125,0x02125); - (0x02127,0x02127); - (0x02129,0x02129); - (0x0212E,0x0212E); - (0x02132,0x02132); - (0x0213A,0x0213A); - (0x0214A,0x0214A); - (0x02195,0x02199); - (0x0219C,0x0219F); - (0x021A1,0x021A2); - (0x021A4,0x021A5); - (0x021A7,0x021AD); - (0x021AF,0x021CD); - (0x021D0,0x021D1); - (0x021D3,0x021D3); - (0x021D5,0x021F3); - (0x02300,0x02307); - (0x0230C,0x0231F); - (0x02322,0x02328); - (0x0232B,0x0237B); - (0x0237D,0x0239A); - (0x023B7,0x023CE); - (0x02400,0x02426); - (0x02440,0x0244A); - (0x0249C,0x024E9); - (0x02500,0x025B6); - (0x025B8,0x025C0); - (0x025C2,0x025F7); - (0x02600,0x02613); - (0x02616,0x02617); - (0x02619,0x0266E); - (0x02670,0x0267D); - (0x02680,0x02689); - (0x02701,0x02704); - (0x02706,0x02709); - (0x0270C,0x02727); - (0x02729,0x0274B); - (0x0274D,0x0274D); - (0x0274F,0x02752); - (0x02756,0x02756); - (0x02758,0x0275E); - (0x02761,0x02767); - (0x02794,0x02794); - (0x02798,0x027AF); - (0x027B1,0x027BE); - (0x02800,0x028FF); - (0x02E80,0x02E99); - (0x02E9B,0x02EF3); - (0x02F00,0x02FD5); - (0x02FF0,0x02FFB); - (0x03004,0x03004); - (0x03012,0x03013); - (0x03020,0x03020); - (0x03036,0x03037); - (0x0303E,0x0303F); - (0x03190,0x03191); - (0x03196,0x0319F); - (0x03200,0x0321C); - (0x0322A,0x03243); - (0x03260,0x0327B); - (0x0327F,0x0327F); - (0x0328A,0x032B0); - (0x032C0,0x032CB); - (0x032D0,0x032FE); - (0x03300,0x03376); - (0x0337B,0x033DD); - (0x033E0,0x033FE); - (0x0A490,0x0A4C6); - (0x0FFE4,0x0FFE4); - (0x0FFE8,0x0FFE8); - (0x0FFED,0x0FFEE); - (0x0FFFC,0x0FFFD); - (0x1D000,0x1D0F5); - (0x1D100,0x1D126); - (0x1D12A,0x1D164); - (0x1D16A,0x1D16C); - (0x1D183,0x1D184); - (0x1D18C,0x1D1A9); - (0x1D1AE,0x1D1DD) -] - -(* Conversion to lower case. *) -let to_lower = [ - (0x00041,0x0005A), `Delta (32); - (0x000C0,0x000D6), `Delta (32); - (0x000D8,0x000DE), `Delta (32); - (0x00100,0x00100), `Abs (0x00101); - (0x00102,0x00102), `Abs (0x00103); - (0x00104,0x00104), `Abs (0x00105); - (0x00106,0x00106), `Abs (0x00107); - (0x00108,0x00108), `Abs (0x00109); - (0x0010A,0x0010A), `Abs (0x0010B); - (0x0010C,0x0010C), `Abs (0x0010D); - (0x0010E,0x0010E), `Abs (0x0010F); - (0x00110,0x00110), `Abs (0x00111); - (0x00112,0x00112), `Abs (0x00113); - (0x00114,0x00114), `Abs (0x00115); - (0x00116,0x00116), `Abs (0x00117); - (0x00118,0x00118), `Abs (0x00119); - (0x0011A,0x0011A), `Abs (0x0011B); - (0x0011C,0x0011C), `Abs (0x0011D); - (0x0011E,0x0011E), `Abs (0x0011F); - (0x00120,0x00120), `Abs (0x00121); - (0x00122,0x00122), `Abs (0x00123); - (0x00124,0x00124), `Abs (0x00125); - (0x00126,0x00126), `Abs (0x00127); - (0x00128,0x00128), `Abs (0x00129); - (0x0012A,0x0012A), `Abs (0x0012B); - (0x0012C,0x0012C), `Abs (0x0012D); - (0x0012E,0x0012E), `Abs (0x0012F); - (0x00130,0x00130), `Abs (0x00069); - (0x00132,0x00132), `Abs (0x00133); - (0x00134,0x00134), `Abs (0x00135); - (0x00136,0x00136), `Abs (0x00137); - (0x00139,0x00139), `Abs (0x0013A); - (0x0013B,0x0013B), `Abs (0x0013C); - (0x0013D,0x0013D), `Abs (0x0013E); - (0x0013F,0x0013F), `Abs (0x00140); - (0x00141,0x00141), `Abs (0x00142); - (0x00143,0x00143), `Abs (0x00144); - (0x00145,0x00145), `Abs (0x00146); - (0x00147,0x00147), `Abs (0x00148); - (0x0014A,0x0014A), `Abs (0x0014B); - (0x0014C,0x0014C), `Abs (0x0014D); - (0x0014E,0x0014E), `Abs (0x0014F); - (0x00150,0x00150), `Abs (0x00151); - (0x00152,0x00152), `Abs (0x00153); - (0x00154,0x00154), `Abs (0x00155); - (0x00156,0x00156), `Abs (0x00157); - (0x00158,0x00158), `Abs (0x00159); - (0x0015A,0x0015A), `Abs (0x0015B); - (0x0015C,0x0015C), `Abs (0x0015D); - (0x0015E,0x0015E), `Abs (0x0015F); - (0x00160,0x00160), `Abs (0x00161); - (0x00162,0x00162), `Abs (0x00163); - (0x00164,0x00164), `Abs (0x00165); - (0x00166,0x00166), `Abs (0x00167); - (0x00168,0x00168), `Abs (0x00169); - (0x0016A,0x0016A), `Abs (0x0016B); - (0x0016C,0x0016C), `Abs (0x0016D); - (0x0016E,0x0016E), `Abs (0x0016F); - (0x00170,0x00170), `Abs (0x00171); - (0x00172,0x00172), `Abs (0x00173); - (0x00174,0x00174), `Abs (0x00175); - (0x00176,0x00176), `Abs (0x00177); - (0x00178,0x00178), `Abs (0x000FF); - (0x00179,0x00179), `Abs (0x0017A); - (0x0017B,0x0017B), `Abs (0x0017C); - (0x0017D,0x0017D), `Abs (0x0017E); - (0x00181,0x00181), `Abs (0x00253); - (0x00182,0x00182), `Abs (0x00183); - (0x00184,0x00184), `Abs (0x00185); - (0x00186,0x00186), `Abs (0x00254); - (0x00187,0x00187), `Abs (0x00188); - (0x00189,0x0018A), `Delta (205); - (0x0018B,0x0018B), `Abs (0x0018C); - (0x0018E,0x0018E), `Abs (0x001DD); - (0x0018F,0x0018F), `Abs (0x00259); - (0x00190,0x00190), `Abs (0x0025B); - (0x00191,0x00191), `Abs (0x00192); - (0x00193,0x00193), `Abs (0x00260); - (0x00194,0x00194), `Abs (0x00263); - (0x00196,0x00196), `Abs (0x00269); - (0x00197,0x00197), `Abs (0x00268); - (0x00198,0x00198), `Abs (0x00199); - (0x0019C,0x0019C), `Abs (0x0026F); - (0x0019D,0x0019D), `Abs (0x00272); - (0x0019F,0x0019F), `Abs (0x00275); - (0x001A0,0x001A0), `Abs (0x001A1); - (0x001A2,0x001A2), `Abs (0x001A3); - (0x001A4,0x001A4), `Abs (0x001A5); - (0x001A6,0x001A6), `Abs (0x00280); - (0x001A7,0x001A7), `Abs (0x001A8); - (0x001A9,0x001A9), `Abs (0x00283); - (0x001AC,0x001AC), `Abs (0x001AD); - (0x001AE,0x001AE), `Abs (0x00288); - (0x001AF,0x001AF), `Abs (0x001B0); - (0x001B1,0x001B2), `Delta (217); - (0x001B3,0x001B3), `Abs (0x001B4); - (0x001B5,0x001B5), `Abs (0x001B6); - (0x001B7,0x001B7), `Abs (0x00292); - (0x001B8,0x001B8), `Abs (0x001B9); - (0x001BC,0x001BC), `Abs (0x001BD); - (0x001C4,0x001C4), `Abs (0x001C6); - (0x001C7,0x001C7), `Abs (0x001C9); - (0x001CA,0x001CA), `Abs (0x001CC); - (0x001CD,0x001CD), `Abs (0x001CE); - (0x001CF,0x001CF), `Abs (0x001D0); - (0x001D1,0x001D1), `Abs (0x001D2); - (0x001D3,0x001D3), `Abs (0x001D4); - (0x001D5,0x001D5), `Abs (0x001D6); - (0x001D7,0x001D7), `Abs (0x001D8); - (0x001D9,0x001D9), `Abs (0x001DA); - (0x001DB,0x001DB), `Abs (0x001DC); - (0x001DE,0x001DE), `Abs (0x001DF); - (0x001E0,0x001E0), `Abs (0x001E1); - (0x001E2,0x001E2), `Abs (0x001E3); - (0x001E4,0x001E4), `Abs (0x001E5); - (0x001E6,0x001E6), `Abs (0x001E7); - (0x001E8,0x001E8), `Abs (0x001E9); - (0x001EA,0x001EA), `Abs (0x001EB); - (0x001EC,0x001EC), `Abs (0x001ED); - (0x001EE,0x001EE), `Abs (0x001EF); - (0x001F1,0x001F1), `Abs (0x001F3); - (0x001F4,0x001F4), `Abs (0x001F5); - (0x001F6,0x001F6), `Abs (0x00195); - (0x001F7,0x001F7), `Abs (0x001BF); - (0x001F8,0x001F8), `Abs (0x001F9); - (0x001FA,0x001FA), `Abs (0x001FB); - (0x001FC,0x001FC), `Abs (0x001FD); - (0x001FE,0x001FE), `Abs (0x001FF); - (0x00200,0x00200), `Abs (0x00201); - (0x00202,0x00202), `Abs (0x00203); - (0x00204,0x00204), `Abs (0x00205); - (0x00206,0x00206), `Abs (0x00207); - (0x00208,0x00208), `Abs (0x00209); - (0x0020A,0x0020A), `Abs (0x0020B); - (0x0020C,0x0020C), `Abs (0x0020D); - (0x0020E,0x0020E), `Abs (0x0020F); - (0x00210,0x00210), `Abs (0x00211); - (0x00212,0x00212), `Abs (0x00213); - (0x00214,0x00214), `Abs (0x00215); - (0x00216,0x00216), `Abs (0x00217); - (0x00218,0x00218), `Abs (0x00219); - (0x0021A,0x0021A), `Abs (0x0021B); - (0x0021C,0x0021C), `Abs (0x0021D); - (0x0021E,0x0021E), `Abs (0x0021F); - (0x00220,0x00220), `Abs (0x0019E); - (0x00222,0x00222), `Abs (0x00223); - (0x00224,0x00224), `Abs (0x00225); - (0x00226,0x00226), `Abs (0x00227); - (0x00228,0x00228), `Abs (0x00229); - (0x0022A,0x0022A), `Abs (0x0022B); - (0x0022C,0x0022C), `Abs (0x0022D); - (0x0022E,0x0022E), `Abs (0x0022F); - (0x00230,0x00230), `Abs (0x00231); - (0x00232,0x00232), `Abs (0x00233); - (0x00386,0x00386), `Abs (0x003AC); - (0x00388,0x0038A), `Delta (37); - (0x0038C,0x0038C), `Abs (0x003CC); - (0x0038E,0x0038F), `Delta (63); - (0x00391,0x003A1), `Delta (32); - (0x003A3,0x003AB), `Delta (32); - (0x003D8,0x003D8), `Abs (0x003D9); - (0x003DA,0x003DA), `Abs (0x003DB); - (0x003DC,0x003DC), `Abs (0x003DD); - (0x003DE,0x003DE), `Abs (0x003DF); - (0x003E0,0x003E0), `Abs (0x003E1); - (0x003E2,0x003E2), `Abs (0x003E3); - (0x003E4,0x003E4), `Abs (0x003E5); - (0x003E6,0x003E6), `Abs (0x003E7); - (0x003E8,0x003E8), `Abs (0x003E9); - (0x003EA,0x003EA), `Abs (0x003EB); - (0x003EC,0x003EC), `Abs (0x003ED); - (0x003EE,0x003EE), `Abs (0x003EF); - (0x003F4,0x003F4), `Abs (0x003B8); - (0x00400,0x0040F), `Delta (80); - (0x00410,0x0042F), `Delta (32); - (0x00460,0x00460), `Abs (0x00461); - (0x00462,0x00462), `Abs (0x00463); - (0x00464,0x00464), `Abs (0x00465); - (0x00466,0x00466), `Abs (0x00467); - (0x00468,0x00468), `Abs (0x00469); - (0x0046A,0x0046A), `Abs (0x0046B); - (0x0046C,0x0046C), `Abs (0x0046D); - (0x0046E,0x0046E), `Abs (0x0046F); - (0x00470,0x00470), `Abs (0x00471); - (0x00472,0x00472), `Abs (0x00473); - (0x00474,0x00474), `Abs (0x00475); - (0x00476,0x00476), `Abs (0x00477); - (0x00478,0x00478), `Abs (0x00479); - (0x0047A,0x0047A), `Abs (0x0047B); - (0x0047C,0x0047C), `Abs (0x0047D); - (0x0047E,0x0047E), `Abs (0x0047F); - (0x00480,0x00480), `Abs (0x00481); - (0x0048A,0x0048A), `Abs (0x0048B); - (0x0048C,0x0048C), `Abs (0x0048D); - (0x0048E,0x0048E), `Abs (0x0048F); - (0x00490,0x00490), `Abs (0x00491); - (0x00492,0x00492), `Abs (0x00493); - (0x00494,0x00494), `Abs (0x00495); - (0x00496,0x00496), `Abs (0x00497); - (0x00498,0x00498), `Abs (0x00499); - (0x0049A,0x0049A), `Abs (0x0049B); - (0x0049C,0x0049C), `Abs (0x0049D); - (0x0049E,0x0049E), `Abs (0x0049F); - (0x004A0,0x004A0), `Abs (0x004A1); - (0x004A2,0x004A2), `Abs (0x004A3); - (0x004A4,0x004A4), `Abs (0x004A5); - (0x004A6,0x004A6), `Abs (0x004A7); - (0x004A8,0x004A8), `Abs (0x004A9); - (0x004AA,0x004AA), `Abs (0x004AB); - (0x004AC,0x004AC), `Abs (0x004AD); - (0x004AE,0x004AE), `Abs (0x004AF); - (0x004B0,0x004B0), `Abs (0x004B1); - (0x004B2,0x004B2), `Abs (0x004B3); - (0x004B4,0x004B4), `Abs (0x004B5); - (0x004B6,0x004B6), `Abs (0x004B7); - (0x004B8,0x004B8), `Abs (0x004B9); - (0x004BA,0x004BA), `Abs (0x004BB); - (0x004BC,0x004BC), `Abs (0x004BD); - (0x004BE,0x004BE), `Abs (0x004BF); - (0x004C1,0x004C1), `Abs (0x004C2); - (0x004C3,0x004C3), `Abs (0x004C4); - (0x004C5,0x004C5), `Abs (0x004C6); - (0x004C7,0x004C7), `Abs (0x004C8); - (0x004C9,0x004C9), `Abs (0x004CA); - (0x004CB,0x004CB), `Abs (0x004CC); - (0x004CD,0x004CD), `Abs (0x004CE); - (0x004D0,0x004D0), `Abs (0x004D1); - (0x004D2,0x004D2), `Abs (0x004D3); - (0x004D4,0x004D4), `Abs (0x004D5); - (0x004D6,0x004D6), `Abs (0x004D7); - (0x004D8,0x004D8), `Abs (0x004D9); - (0x004DA,0x004DA), `Abs (0x004DB); - (0x004DC,0x004DC), `Abs (0x004DD); - (0x004DE,0x004DE), `Abs (0x004DF); - (0x004E0,0x004E0), `Abs (0x004E1); - (0x004E2,0x004E2), `Abs (0x004E3); - (0x004E4,0x004E4), `Abs (0x004E5); - (0x004E6,0x004E6), `Abs (0x004E7); - (0x004E8,0x004E8), `Abs (0x004E9); - (0x004EA,0x004EA), `Abs (0x004EB); - (0x004EC,0x004EC), `Abs (0x004ED); - (0x004EE,0x004EE), `Abs (0x004EF); - (0x004F0,0x004F0), `Abs (0x004F1); - (0x004F2,0x004F2), `Abs (0x004F3); - (0x004F4,0x004F4), `Abs (0x004F5); - (0x004F8,0x004F8), `Abs (0x004F9); - (0x00500,0x00500), `Abs (0x00501); - (0x00502,0x00502), `Abs (0x00503); - (0x00504,0x00504), `Abs (0x00505); - (0x00506,0x00506), `Abs (0x00507); - (0x00508,0x00508), `Abs (0x00509); - (0x0050A,0x0050A), `Abs (0x0050B); - (0x0050C,0x0050C), `Abs (0x0050D); - (0x0050E,0x0050E), `Abs (0x0050F); - (0x00531,0x00556), `Delta (48); - (0x01E00,0x01E00), `Abs (0x01E01); - (0x01E02,0x01E02), `Abs (0x01E03); - (0x01E04,0x01E04), `Abs (0x01E05); - (0x01E06,0x01E06), `Abs (0x01E07); - (0x01E08,0x01E08), `Abs (0x01E09); - (0x01E0A,0x01E0A), `Abs (0x01E0B); - (0x01E0C,0x01E0C), `Abs (0x01E0D); - (0x01E0E,0x01E0E), `Abs (0x01E0F); - (0x01E10,0x01E10), `Abs (0x01E11); - (0x01E12,0x01E12), `Abs (0x01E13); - (0x01E14,0x01E14), `Abs (0x01E15); - (0x01E16,0x01E16), `Abs (0x01E17); - (0x01E18,0x01E18), `Abs (0x01E19); - (0x01E1A,0x01E1A), `Abs (0x01E1B); - (0x01E1C,0x01E1C), `Abs (0x01E1D); - (0x01E1E,0x01E1E), `Abs (0x01E1F); - (0x01E20,0x01E20), `Abs (0x01E21); - (0x01E22,0x01E22), `Abs (0x01E23); - (0x01E24,0x01E24), `Abs (0x01E25); - (0x01E26,0x01E26), `Abs (0x01E27); - (0x01E28,0x01E28), `Abs (0x01E29); - (0x01E2A,0x01E2A), `Abs (0x01E2B); - (0x01E2C,0x01E2C), `Abs (0x01E2D); - (0x01E2E,0x01E2E), `Abs (0x01E2F); - (0x01E30,0x01E30), `Abs (0x01E31); - (0x01E32,0x01E32), `Abs (0x01E33); - (0x01E34,0x01E34), `Abs (0x01E35); - (0x01E36,0x01E36), `Abs (0x01E37); - (0x01E38,0x01E38), `Abs (0x01E39); - (0x01E3A,0x01E3A), `Abs (0x01E3B); - (0x01E3C,0x01E3C), `Abs (0x01E3D); - (0x01E3E,0x01E3E), `Abs (0x01E3F); - (0x01E40,0x01E40), `Abs (0x01E41); - (0x01E42,0x01E42), `Abs (0x01E43); - (0x01E44,0x01E44), `Abs (0x01E45); - (0x01E46,0x01E46), `Abs (0x01E47); - (0x01E48,0x01E48), `Abs (0x01E49); - (0x01E4A,0x01E4A), `Abs (0x01E4B); - (0x01E4C,0x01E4C), `Abs (0x01E4D); - (0x01E4E,0x01E4E), `Abs (0x01E4F); - (0x01E50,0x01E50), `Abs (0x01E51); - (0x01E52,0x01E52), `Abs (0x01E53); - (0x01E54,0x01E54), `Abs (0x01E55); - (0x01E56,0x01E56), `Abs (0x01E57); - (0x01E58,0x01E58), `Abs (0x01E59); - (0x01E5A,0x01E5A), `Abs (0x01E5B); - (0x01E5C,0x01E5C), `Abs (0x01E5D); - (0x01E5E,0x01E5E), `Abs (0x01E5F); - (0x01E60,0x01E60), `Abs (0x01E61); - (0x01E62,0x01E62), `Abs (0x01E63); - (0x01E64,0x01E64), `Abs (0x01E65); - (0x01E66,0x01E66), `Abs (0x01E67); - (0x01E68,0x01E68), `Abs (0x01E69); - (0x01E6A,0x01E6A), `Abs (0x01E6B); - (0x01E6C,0x01E6C), `Abs (0x01E6D); - (0x01E6E,0x01E6E), `Abs (0x01E6F); - (0x01E70,0x01E70), `Abs (0x01E71); - (0x01E72,0x01E72), `Abs (0x01E73); - (0x01E74,0x01E74), `Abs (0x01E75); - (0x01E76,0x01E76), `Abs (0x01E77); - (0x01E78,0x01E78), `Abs (0x01E79); - (0x01E7A,0x01E7A), `Abs (0x01E7B); - (0x01E7C,0x01E7C), `Abs (0x01E7D); - (0x01E7E,0x01E7E), `Abs (0x01E7F); - (0x01E80,0x01E80), `Abs (0x01E81); - (0x01E82,0x01E82), `Abs (0x01E83); - (0x01E84,0x01E84), `Abs (0x01E85); - (0x01E86,0x01E86), `Abs (0x01E87); - (0x01E88,0x01E88), `Abs (0x01E89); - (0x01E8A,0x01E8A), `Abs (0x01E8B); - (0x01E8C,0x01E8C), `Abs (0x01E8D); - (0x01E8E,0x01E8E), `Abs (0x01E8F); - (0x01E90,0x01E90), `Abs (0x01E91); - (0x01E92,0x01E92), `Abs (0x01E93); - (0x01E94,0x01E94), `Abs (0x01E95); - (0x01EA0,0x01EA0), `Abs (0x01EA1); - (0x01EA2,0x01EA2), `Abs (0x01EA3); - (0x01EA4,0x01EA4), `Abs (0x01EA5); - (0x01EA6,0x01EA6), `Abs (0x01EA7); - (0x01EA8,0x01EA8), `Abs (0x01EA9); - (0x01EAA,0x01EAA), `Abs (0x01EAB); - (0x01EAC,0x01EAC), `Abs (0x01EAD); - (0x01EAE,0x01EAE), `Abs (0x01EAF); - (0x01EB0,0x01EB0), `Abs (0x01EB1); - (0x01EB2,0x01EB2), `Abs (0x01EB3); - (0x01EB4,0x01EB4), `Abs (0x01EB5); - (0x01EB6,0x01EB6), `Abs (0x01EB7); - (0x01EB8,0x01EB8), `Abs (0x01EB9); - (0x01EBA,0x01EBA), `Abs (0x01EBB); - (0x01EBC,0x01EBC), `Abs (0x01EBD); - (0x01EBE,0x01EBE), `Abs (0x01EBF); - (0x01EC0,0x01EC0), `Abs (0x01EC1); - (0x01EC2,0x01EC2), `Abs (0x01EC3); - (0x01EC4,0x01EC4), `Abs (0x01EC5); - (0x01EC6,0x01EC6), `Abs (0x01EC7); - (0x01EC8,0x01EC8), `Abs (0x01EC9); - (0x01ECA,0x01ECA), `Abs (0x01ECB); - (0x01ECC,0x01ECC), `Abs (0x01ECD); - (0x01ECE,0x01ECE), `Abs (0x01ECF); - (0x01ED0,0x01ED0), `Abs (0x01ED1); - (0x01ED2,0x01ED2), `Abs (0x01ED3); - (0x01ED4,0x01ED4), `Abs (0x01ED5); - (0x01ED6,0x01ED6), `Abs (0x01ED7); - (0x01ED8,0x01ED8), `Abs (0x01ED9); - (0x01EDA,0x01EDA), `Abs (0x01EDB); - (0x01EDC,0x01EDC), `Abs (0x01EDD); - (0x01EDE,0x01EDE), `Abs (0x01EDF); - (0x01EE0,0x01EE0), `Abs (0x01EE1); - (0x01EE2,0x01EE2), `Abs (0x01EE3); - (0x01EE4,0x01EE4), `Abs (0x01EE5); - (0x01EE6,0x01EE6), `Abs (0x01EE7); - (0x01EE8,0x01EE8), `Abs (0x01EE9); - (0x01EEA,0x01EEA), `Abs (0x01EEB); - (0x01EEC,0x01EEC), `Abs (0x01EED); - (0x01EEE,0x01EEE), `Abs (0x01EEF); - (0x01EF0,0x01EF0), `Abs (0x01EF1); - (0x01EF2,0x01EF2), `Abs (0x01EF3); - (0x01EF4,0x01EF4), `Abs (0x01EF5); - (0x01EF6,0x01EF6), `Abs (0x01EF7); - (0x01EF8,0x01EF8), `Abs (0x01EF9); - (0x01F08,0x01F0F), `Delta (-8); - (0x01F18,0x01F1D), `Delta (-8); - (0x01F28,0x01F2F), `Delta (-8); - (0x01F38,0x01F3F), `Delta (-8); - (0x01F48,0x01F4D), `Delta (-8); - (0x01F59,0x01F59), `Abs (0x01F51); - (0x01F5B,0x01F5B), `Abs (0x01F53); - (0x01F5D,0x01F5D), `Abs (0x01F55); - (0x01F5F,0x01F5F), `Abs (0x01F57); - (0x01F68,0x01F6F), `Delta (-8); - (0x01FB8,0x01FB9), `Delta (-8); - (0x01FBA,0x01FBB), `Delta (-74); - (0x01FC8,0x01FCB), `Delta (-86); - (0x01FD8,0x01FD9), `Delta (-8); - (0x01FDA,0x01FDB), `Delta (-100); - (0x01FE8,0x01FE9), `Delta (-8); - (0x01FEA,0x01FEB), `Delta (-112); - (0x01FEC,0x01FEC), `Abs (0x01FE5); - (0x01FF8,0x01FF9), `Delta (-128); - (0x01FFA,0x01FFB), `Delta (-126); - (0x02126,0x02126), `Abs (0x003C9); - (0x0212A,0x0212A), `Abs (0x0006B); - (0x0212B,0x0212B), `Abs (0x000E5); - (0x0FF21,0x0FF3A), `Delta (32); - (0x10400,0x10425), `Delta (40); - (0x001C5,0x001C5), `Abs (0x001C6); - (0x001C8,0x001C8), `Abs (0x001C9); - (0x001CB,0x001CB), `Abs (0x001CC); - (0x001F2,0x001F2), `Abs (0x001F3); - (0x01F88,0x01F8F), `Delta (-8); - (0x01F98,0x01F9F), `Delta (-8); - (0x01FA8,0x01FAF), `Delta (-8); - (0x01FBC,0x01FBC), `Abs (0x01FB3); - (0x01FCC,0x01FCC), `Abs (0x01FC3); - (0x01FFC,0x01FFC), `Abs (0x01FF3); - (0x02160,0x0216F), `Delta (16) -] - diff --git a/lib/unionfind.ml b/lib/unionfind.ml deleted file mode 100644 index 6e131d8f..00000000 --- a/lib/unionfind.ml +++ /dev/null @@ -1,136 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - - (** Add (in place) an element in the partition, or do nothing - if the element is already in the partition. *) - val add : elt -> t -> unit - - (** Find the canonical representative of an element. - Raise [not_found] if the element isn't known yet. *) - val find : elt -> t -> elt - - (** Merge (in place) the equivalence classes of two elements. - This will add the elements in the partition if necessary. *) - val union : elt -> elt -> t -> unit - - (** Merge (in place) the equivalence classes of many elements. *) - val union_set : set -> t -> unit - - (** Listing the different components of the partition *) - val partition : t -> set list - -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 - -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 - - type node = - | Canon of set - | Equiv of elt - - type t = node ref M.t ref - - let create () = ref (M.empty : node ref M.t) - - let fresh x p = - let node = ref (Canon (S.singleton x)) in - p := M.add x node !p; - x, node - - let rec lookup x p = - let node = M.find x !p in - match !node with - | Canon _ -> x, node - | Equiv y -> - let ((z,_) as res) = lookup y p in - if not (z == y) then node := Equiv z; - res - - let add x p = if not (M.mem x !p) then ignore (fresh x p) - - let find x p = fst (lookup x p) - - let canonical x p = try lookup x p with Not_found -> fresh x p - - let union x y p = - let ((x,_) as xcan) = canonical x p in - let ((y,_) as ycan) = canonical y p in - if x = y then () - else - let xcan, ycan = if x < y then xcan, ycan else ycan, xcan in - let x,xnode = xcan and y,ynode = ycan in - match !xnode, !ynode with - | Canon lx, Canon ly -> - xnode := Canon (S.union lx ly); - ynode := Equiv x; - | _ -> assert false - - let union_set s p = - try - let x = S.choose s in - S.iter (fun y -> union x y p) s - with Not_found -> () - - let partition p = - List.rev (M.fold - (fun x node acc -> match !node with - | Equiv _ -> acc - | Canon lx -> lx::acc) - !p []) - -end diff --git a/lib/unionfind.mli b/lib/unionfind.mli deleted file mode 100644 index ea249ae2..00000000 --- a/lib/unionfind.mli +++ /dev/null @@ -1,80 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - - (** Add (in place) an element in the partition, or do nothing - if the element is already in the partition. *) - val add : elt -> t -> unit - - (** Find the canonical representative of an element. - Raise [not_found] if the element isn't known yet. *) - val find : elt -> t -> elt - - (** Merge (in place) the equivalence classes of two elements. - This will add the elements in the partition if necessary. *) - val union : elt -> elt -> t -> unit - - (** Merge (in place) the equivalence classes of many elements. *) - val union_set : set -> t -> unit - - (** Listing the different components of the partition *) - val partition : t -> set list - -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: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 009dfbe1..7d7d380b 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -1,10 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* f2] is [fun x -> f2 (f1 x)]. - So [g % f] is a synonym for [fun x -> g (f x)]. + [f1 %> f2 %> f3] is [fun x -> f3 (f2 (f1 x))]. - Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. - *) -let (%) f g x = f (g x) + [f1 %> f2 %> f3 %> f4] is [fun x -> f4 (f3 (f2 (f1 x)))] + + etc. +*) +let (%>) f g x = g (f x) let const x _ = x @@ -132,6 +138,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 type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq +let sym : type a b. (a, b) eq -> (b, a) eq = fun Refl -> Refl + module Union = struct let map f g = function @@ -157,11 +165,20 @@ let iraise = Exninfo.iraise let open_utf8_file_in fname = let is_bom s = - Int.equal (Char.code s.[0]) 0xEF && - Int.equal (Char.code s.[1]) 0xBB && - Int.equal (Char.code s.[2]) 0xBF + Int.equal (Char.code (Bytes.get s 0)) 0xEF && + Int.equal (Char.code (Bytes.get s 1)) 0xBB && + Int.equal (Char.code (Bytes.get s 2)) 0xBF in let in_chan = open_in fname in - let s = " " in + let s = Bytes.make 3 ' ' in if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; in_chan + +(** A trick which can typically be used to store on the fly the + computation of values in the "when" clause of a "match" then + retrieve the evaluated result in the r.h.s of the clause *) + +let set_temporary_memory () = + let a = ref None in + (fun x -> assert (!a = None); a := Some x; x), + (fun () -> match !a with Some x -> x | None -> assert false) diff --git a/lib/util.mli b/lib/util.mli index 6bed7e35..1eb60f50 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a list list val identity : 'a -> 'a -(** Function composition: the mathematical [∘] operator. +(** Left-to-right function composition: + + [f1 %> f2] is [fun x -> f2 (f1 x)]. - So [g % f] is a synonym for [fun x -> g (f x)]. + [f1 %> f2 %> f3] is [fun x -> f3 (f2 (f1 x))]. - Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. + [f1 %> f2 %> f3 %> f4] is [fun x -> f4 (f3 (f2 (f1 x)))] + + etc. *) -val (%) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b +val ( %> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c val const : 'a -> 'b -> 'a val iterate : ('a -> 'a) -> int -> 'a -> 'a @@ -129,5 +135,12 @@ type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq +val sym : ('a, 'b) eq -> ('b, 'a) eq + val open_utf8_file_in : string -> in_channel (** Open an utf-8 encoded file and skip the byte-order mark if any. *) + +val set_temporary_memory : unit -> ('a -> 'a) * (unit -> 'a) +(** A trick which can typically be used to store on the fly the + computation of values in the "when" clause of a "match" then + retrieve the evaluated result in the r.h.s of the clause *) diff --git a/lib/xml_datatype.mli b/lib/xml_datatype.mli index a8e37935..19c046e9 100644 --- a/lib/xml_datatype.mli +++ b/lib/xml_datatype.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(*