diff options
Diffstat (limited to 'lib')
129 files changed, 11135 insertions, 5426 deletions
diff --git a/lib/aux_file.ml b/lib/aux_file.ml new file mode 100644 index 00000000..c9018c9e --- /dev/null +++ b/lib/aux_file.ml @@ -0,0 +1,92 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* The file format is a header + * ("COQAUX%d %s %s\n" version hex_hash path) + * followed by an arbitrary number of entries + * ("%d %d %s %S\n" loc_begin loc_end key value) *) + +open Filename + +let version = 1 + +let oc = ref None + +let aux_file_name_for vfile = + dirname vfile ^ "/." ^ chop_extension(basename vfile) ^ ".aux" + +let mk_absolute vfile = + let vfile = CUnix.remove_path_dot vfile in + if Filename.is_relative vfile then CUnix.correct_path vfile (Sys.getcwd ()) + else vfile + +let start_aux_file_for vfile = + let vfile = mk_absolute vfile in + oc := Some (open_out (aux_file_name_for vfile)); + Printf.fprintf (Option.get !oc) "COQAUX%d %s %s\n" + version (Digest.to_hex (Digest.file vfile)) vfile + +let stop_aux_file () = + close_out (Option.get !oc); + oc := None + +let recording () = not (Option.is_empty !oc) + +module H = Map.Make(struct type t = int * int let compare = compare end) +module M = Map.Make(String) +type data = string M.t +type aux_file = data H.t + +let empty_aux_file = H.empty + +let get aux loc key = M.find key (H.find (Loc.unloc loc) aux) + +let record_in_aux_at loc key v = + Option.iter (fun oc -> + let i, j = Loc.unloc loc in + Printf.fprintf oc "%d %d %s %S\n" i j key v) + !oc + +let current_loc = ref Loc.ghost + +let record_in_aux_set_at loc = current_loc := loc + +let record_in_aux key v = record_in_aux_at !current_loc key v + +let set h loc k v = + let m = try H.find loc h with Not_found -> M.empty in + H.add loc (M.add k v m) h + +let load_aux_file_for vfile = + let vfile = mk_absolute vfile in + let ret3 x y z = x, y, z in + let ret4 x y z t = x, y, z, t in + let h = ref empty_aux_file in + let add loc k v = h := set !h loc k v in + let aux_fname = aux_file_name_for vfile in + try + let ic = open_in aux_fname in + let ver, hash, fname = Scanf.fscanf ic "COQAUX%d %s %s\n" ret3 in + if ver <> version then raise (Failure "aux file version mismatch"); + if fname <> vfile then + raise (Failure "aux file name mismatch"); + let only_dummyloc = Digest.to_hex (Digest.file vfile) <> hash in + while true do + let i, j, k, v = Scanf.fscanf ic "%d %d %s %S\n" ret4 in + if not only_dummyloc || (i = 0 && j = 0) then add (i,j) k v; + done; + raise End_of_file + with + | End_of_file -> !h + | Sys_error s | Scanf.Scan_failure s + | Failure s | Invalid_argument s -> + Flags.if_verbose + Pp.msg_warning Pp.(str"Loading file "++str aux_fname++str": "++str s); + empty_aux_file + +let set h loc k v = set h (Loc.unloc loc) k v diff --git a/lib/aux_file.mli b/lib/aux_file.mli new file mode 100644 index 00000000..e340fc65 --- /dev/null +++ b/lib/aux_file.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type aux_file + +val load_aux_file_for : string -> aux_file +val get : aux_file -> Loc.t -> string -> string +val empty_aux_file : aux_file +val set : aux_file -> Loc.t -> string -> string -> aux_file + +val start_aux_file_for : string -> unit +val stop_aux_file : unit -> unit +val recording : unit -> bool + +val record_in_aux_at : Loc.t -> string -> string -> unit +val record_in_aux : string -> string -> unit +val record_in_aux_set_at : Loc.t -> unit diff --git a/lib/backtrace.ml b/lib/backtrace.ml new file mode 100644 index 00000000..b3b8bdea --- /dev/null +++ b/lib/backtrace.ml @@ -0,0 +1,116 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +type raw_frame = +| Known_location of bool (* is_raise *) + * string (* filename *) + * int (* line number *) + * int (* start char *) + * int (* end char *) +| Unknown_location of bool (*is_raise*) + +type location = { + loc_filename : string; + loc_line : int; + loc_start : int; + loc_end : int; +} + +type frame = { frame_location : location option; frame_raised : bool; } + +external get_exception_backtrace: unit -> raw_frame array option + = "caml_get_exception_backtrace" + +type t = raw_frame array list +(** List of partial raw stack frames, in reverse order *) + +let empty = [] + +let of_raw = function +| Unknown_location r -> + { frame_location = None; frame_raised = r; } +| Known_location (r, file, line, st, en) -> + let loc = { + loc_filename = file; + loc_line = line; + loc_start = st; + loc_end = en; + } in + { frame_location = Some loc; frame_raised = r; } + +let rec repr_aux accu = function +| [] -> accu +| fragment :: stack -> + let len = Array.length fragment in + let rec append accu i = + if i = len then accu + else append (of_raw fragment.(i) :: accu) (succ i) + in + repr_aux (append accu 0) stack + +let repr bt = repr_aux [] (List.rev bt) + +let push stack = match get_exception_backtrace () with +| None -> [] +| Some frames -> frames :: stack + +(** Utilities *) + +let print_frame frame = + let raise = if frame.frame_raised then "raise" else "frame" in + match frame.frame_location with + | None -> Printf.sprintf "%s @ unknown" raise + | Some loc -> + Printf.sprintf "%s @ file \"%s\", line %d, characters %d-%d" + raise loc.loc_filename loc.loc_line loc.loc_start loc.loc_end + +(** Exception manipulation *) + +let backtrace : t Exninfo.t = Exninfo.make () + +let is_recording = ref false + +let record_backtrace b = + let () = Printexc.record_backtrace b in + is_recording := b + +let get_backtrace e = + Exninfo.get e backtrace + +let add_backtrace e = + if !is_recording then + (** This must be the first function call, otherwise the stack may be + destroyed *) + let current = get_exception_backtrace () in + let info = Exninfo.info e in + begin match current with + | None -> (e, info) + | Some fragment -> + let bt = match get_backtrace info with + | None -> [] + | Some bt -> bt + in + let bt = fragment :: bt in + (e, Exninfo.add info backtrace bt) + end + else + let info = Exninfo.info e in + (e, info) + +let app_backtrace ~src ~dst = + if !is_recording then + match get_backtrace src with + | None -> dst + | Some bt -> + match get_backtrace dst with + | None -> + Exninfo.add dst backtrace bt + | Some nbt -> + let bt = bt @ nbt in + Exninfo.add dst backtrace bt + else dst diff --git a/lib/backtrace.mli b/lib/backtrace.mli new file mode 100644 index 00000000..dd82165b --- /dev/null +++ b/lib/backtrace.mli @@ -0,0 +1,96 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** * Low-level management of OCaml backtraces. + + Currently, OCaml manages its backtraces in a very imperative way. That is to + say, it only keeps track of the stack destroyed by the last raised exception. + So we have to be very careful when using this module not to do silly things. + + Basically, you need to manually handle the reraising of exceptions. In order + to do so, each time the backtrace is lost, you must [push] the stack fragment. + This essentially occurs whenever a [with] handler is crossed. + +*) + +(** {5 Backtrace information} *) + +type location = { + loc_filename : string; + loc_line : int; + loc_start : int; + loc_end : int; +} +(** OCaml debugging information for function calls. *) + +type frame = { frame_location : location option; frame_raised : bool; } +(** A frame contains two informations: its optional physical location, and + whether it raised the exception or let it pass through. *) + +type t +(** Type of backtraces. They're essentially stack of frames. *) + +val empty : t +(** Empty frame stack. *) + +val push : t -> t +(** Add the current backtrace information to a given backtrace. *) + +val repr : t -> frame list +(** Represent a backtrace as a list of frames. Leftmost element is the outermost + call. *) + +(** {5 Utilities} *) + +val print_frame : frame -> string +(** Represent a frame. *) + +(** {5 Exception handling} *) + +val record_backtrace : bool -> unit +(** Whether to activate the backtrace recording mechanism. Note that it will + only work whenever the program was compiled with the [debug] flag. *) + +val get_backtrace : Exninfo.info -> t option +(** Retrieve the optional backtrace coming with the exception. *) + +val add_backtrace : exn -> Exninfo.iexn +(** Add the current backtrace information to the given exception. + + The intended use case is of the form: {[ + + try foo + with + | Bar -> bar + | err -> let err = add_backtrace err in baz + + ]} + + WARNING: any intermediate code between the [with] and the handler may + modify the backtrace. Yes, that includes [when] clauses. Ideally, what you + should do is something like: {[ + + try foo + with err -> + let err = add_backtrace err in + match err with + | Bar -> bar + | err -> baz + + ]} + + I admit that's a bit heavy, but there is not much to do... + +*) + +val app_backtrace : src:Exninfo.info -> dst:Exninfo.info -> Exninfo.info +(** Append the backtrace from [src] to [dst]. The returned exception is [dst] + except for its backtrace information. This is targeted at container + exceptions, that is, exceptions that contain exceptions. This way, one can + transfer the backtrace from the container to the underlying exception, as if + the latter was the one originally raised. *) diff --git a/lib/bigint.ml b/lib/bigint.ml index 42a71f83..e739c7a1 100644 --- a/lib/bigint.ml +++ b/lib/bigint.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -43,11 +43,11 @@ let size = let format_size = (* How to parametrize a printf format *) - if size = 4 then Printf.sprintf "%04d" - else if size = 9 then Printf.sprintf "%09d" + if Int.equal size 4 then Printf.sprintf "%04d" + else if Int.equal size 9 then Printf.sprintf "%09d" else fun n -> let rec aux j l n = - if j=size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10) + if Int.equal j size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10) in String.concat "" (aux 0 [] n) (* The base is 10^size *) @@ -63,27 +63,31 @@ module ArrayInt = struct (* Basic numbers *) let zero = [||] -let neg_one = [|-1|] + +let is_zero = function +| [||] -> true +| _ -> false (* An array is canonical when - it is empty - it is [|-1|] - its first bloc is in [-base;-1[U]0;base[ and the other blocs are in [0;base[. *) - +(* let canonical n = let ok x = (0 <= x && x < base) in - let rec ok_tail k = (k = 0) || (ok n.(k) && ok_tail (k-1)) in - let ok_init x = (-base <= x && x < base && x <> -1 && x <> 0) + let rec ok_tail k = (Int.equal k 0) || (ok n.(k) && ok_tail (k-1)) in + let ok_init x = (-base <= x && x < base && not (Int.equal x (-1)) && not (Int.equal x 0)) in - (n = [||]) || (n = [|-1|]) || + (is_zero n) || (match n with [|-1|] -> true | _ -> false) || (ok_init n.(0) && ok_tail (Array.length n - 1)) +*) (* [normalize_pos] : removing initial blocks of 0 *) let normalize_pos n = let k = ref 0 in - while !k < Array.length n & n.(!k) = 0 do incr k done; + while !k < Array.length n && Int.equal n.(!k) 0 do incr k done; Array.sub n !k (Array.length n - !k) (* [normalize_neg] : avoid (-1) as first bloc. @@ -92,32 +96,32 @@ let normalize_pos n = let normalize_neg n = let k = ref 1 in - while !k < Array.length n & n.(!k) = base - 1 do incr k done; + while !k < Array.length n && Int.equal n.(!k) (base - 1) do incr k done; let n' = Array.sub n !k (Array.length n - !k) in - if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n') + if Int.equal (Array.length n') 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n') (* [normalize] : avoid 0 and (-1) as first bloc. input: an array with first bloc in [-base;base[ and others in [0;base[ output: a canonical array *) -let rec normalize n = - if Array.length n = 0 then n - else if n.(0) = -1 then normalize_neg n - else if n.(0) = 0 then normalize_pos n +let normalize n = + if Int.equal (Array.length n) 0 then n + else if Int.equal n.(0) (-1) then normalize_neg n + else if Int.equal n.(0) 0 then normalize_pos n else n (* Opposite (expects and returns canonical arrays) *) let neg m = - if m = zero then zero else + if is_zero m then zero else let n = Array.copy m in let i = ref (Array.length m - 1) in - while !i > 0 & n.(!i) = 0 do decr i done; - if !i = 0 then begin + while !i > 0 && Int.equal n.(!i) 0 do decr i done; + if Int.equal !i 0 then begin n.(0) <- - n.(0); (* n.(0) cannot be 0 since m is canonical *) - if n.(0) = -1 then normalize_neg n - else if n.(0) = base then (n.(0) <- 0; Array.append [| 1 |] n) + if Int.equal n.(0) (-1) then normalize_neg n + else if Int.equal n.(0) base then (n.(0) <- 0; Array.append [| 1 |] n) else n end else begin (* here n.(!i) <> 0, hence 0 < base - n.(!i) < base for n canonical *) @@ -132,10 +136,10 @@ let neg m = let push_carry r j = let j = ref j in - while !j > 0 & r.(!j) < 0 do + while !j > 0 && r.(!j) < 0 do r.(!j) <- r.(!j) + base; decr j; r.(!j) <- r.(!j) - 1 done; - while !j > 0 & r.(!j) >= base do + while !j > 0 && r.(!j) >= base do r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1 done; (* here r.(0) could be in [-2*base;2*base-1] *) @@ -144,7 +148,7 @@ let push_carry r j = else normalize r (* in case r.(0) is 0 or -1 *) let add_to r a j = - if a = zero then r else begin + if is_zero a then r else begin for i = Array.length r - 1 downto j+1 do r.(i) <- r.(i) + a.(i-j); if r.(i) >= base then (r.(i) <- r.(i) - base; r.(i-1) <- r.(i-1) + 1) @@ -158,7 +162,7 @@ let add n m = if d > 0 then add_to (Array.copy n) m d else add_to (Array.copy m) n (-d) let sub_to r a j = - if a = zero then r else begin + if is_zero a then r else begin for i = Array.length r - 1 downto j+1 do r.(i) <- r.(i) - a.(i-j); if r.(i) < 0 then (r.(i) <- r.(i) + base; r.(i-1) <- r.(i-1) - 1) @@ -172,10 +176,10 @@ let sub n m = if d >= 0 then sub_to (Array.copy n) m d else let r = neg m in add_to r n (Array.length r - Array.length n) -let rec mult m n = - if m = zero or n = zero then zero else +let mult m n = + if is_zero m || is_zero n then zero else let l = Array.length m + Array.length n in - let r = Array.create l 0 in + let r = Array.make l 0 in for i = Array.length m - 1 downto 0 do for j = Array.length n - 1 downto 0 do let p = m.(i) * n.(j) + r.(i+j+1) in @@ -184,49 +188,62 @@ let rec mult m n = then (p + 1) / base - 1, (p + 1) mod base + base - 1 else p / base, p mod base in r.(i+j+1) <- s; - if q <> 0 then r.(i+j) <- r.(i+j) + q; + if not (Int.equal q 0) then r.(i+j) <- r.(i+j) + q; done done; normalize r (* Comparisons *) -let is_strictly_neg n = n<>[||] && n.(0) < 0 -let is_strictly_pos n = n<>[||] && n.(0) > 0 -let is_neg_or_zero n = n=[||] or n.(0) < 0 -let is_pos_or_zero n = n=[||] or n.(0) > 0 +let is_strictly_neg n = not (is_zero n) && n.(0) < 0 +let is_strictly_pos n = not (is_zero n) && n.(0) > 0 +let is_neg_or_zero n = is_zero n || n.(0) < 0 +let is_pos_or_zero n = is_zero n || n.(0) > 0 + +(* Is m without its i first blocs less then n without its j first blocs ? + Invariant : |m|-i = |n|-j *) let rec less_than_same_size m n i j = i < Array.length m && - (m.(i) < n.(j) or (m.(i) = n.(j) && less_than_same_size m n (i+1) (j+1))) + (m.(i) < n.(j) || (Int.equal m.(i) n.(j) && less_than_same_size m n (i+1) (j+1))) let less_than m n = if is_strictly_neg m then - is_pos_or_zero n or Array.length m > Array.length n - or (Array.length m = Array.length n && less_than_same_size m n 0 0) + is_pos_or_zero n || Array.length m > Array.length n + || (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0) else - is_strictly_pos n && (Array.length m < Array.length n or - (Array.length m = Array.length n && less_than_same_size m n 0 0)) + is_strictly_pos n && (Array.length m < Array.length n || + (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0)) (* For this equality test it is critical that n and m are canonical *) -let equal m n = (m = n) +let rec array_eq len v1 v2 i = + if Int.equal len i then true + else + Int.equal v1.(i) v2.(i) && array_eq len v1 v2 (succ i) + +let equal m n = + let lenm = Array.length m in + let lenn = Array.length n in + (Int.equal lenm lenn) && (array_eq lenm m n 0) + +(* Is m without its k top blocs less than n ? *) let less_than_shift_pos k m n = (Array.length m - k < Array.length n) - or (Array.length m - k = Array.length n && less_than_same_size m n k 0) + || (Int.equal (Array.length m - k) (Array.length n) && less_than_same_size m n k 0) let rec can_divide k m d i = - (i = Array.length d) or - (m.(k+i) > d.(i)) or - (m.(k+i) = d.(i) && can_divide k m d (i+1)) + (Int.equal i (Array.length d)) || + (m.(k+i) > d.(i)) || + (Int.equal m.(k+i) d.(i) && can_divide k m d (i+1)) (* For two big nums m and d and a small number q, computes m - d * q * base^(|m|-|d|-k) in-place (in m). Both m d and q are positive. *) let sub_mult m d q k = - if q <> 0 then + if not (Int.equal q 0) then for i = Array.length d - 1 downto 0 do let v = d.(i) * q in m.(k+i) <- m.(k+i) - v mod base; @@ -249,17 +266,17 @@ let euclid m d = let isnegm, m = if is_strictly_neg m then (-1),neg m else 1,Array.copy m in let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in - if d = zero then raise Division_by_zero; + if is_zero d then raise Division_by_zero; let q,r = if less_than m d then (zero,m) else let ql = Array.length m - Array.length d in - let q = Array.create (ql+1) 0 in + let q = Array.make (ql+1) 0 in let i = ref 0 in while not (less_than_shift_pos !i m d) do - if m.(!i)=0 then incr i else + if Int.equal m.(!i) 0 then incr i else if can_divide !i m d 0 then begin let v = - if Array.length d > 1 && d.(0) <> m.(!i) then + if Array.length d > 1 && not (Int.equal d.(0) m.(!i)) then (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1) else m.(!i) / d.(0) in @@ -276,30 +293,30 @@ let euclid m d = end done; (normalize q, normalize m) in - (if isnegd * isnegm = -1 then neg q else q), - (if isnegm = -1 then neg r else r) + (if Int.equal (isnegd * isnegm) (-1) then neg q else q), + (if Int.equal isnegm (-1) then neg r else r) (* Parsing/printing ordinary 10-based numbers *) let of_string s = let len = String.length s in - let isneg = len > 1 & s.[0] = '-' in + let isneg = len > 1 && s.[0] == '-' in let d = ref (if isneg then 1 else 0) in - while !d < len && s.[!d] = '0' do incr d done; - if !d = len then zero else + while !d < len && s.[!d] == '0' do incr d done; + if Int.equal !d len then zero else let r = (len - !d) mod size in let h = String.sub s (!d) r in - let e = if h<>"" then 1 else 0 in + let e = match h with "" -> 0 | _ -> 1 in let l = (len - !d) / size in - let a = Array.create (l + e) 0 in - if e=1 then a.(0) <- int_of_string h; - for i=1 to l do + let a = Array.make (l + e) 0 in + if Int.equal e 1 then a.(0) <- int_of_string h; + for i = 1 to l do a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size) done; if isneg then neg a else a let to_string_pos sgn n = - if Array.length n = 0 then "0" else + if Int.equal (Array.length n) 0 then "0" else sgn ^ String.concat "" (string_of_int n.(0) :: List.map format_size (List.tl (Array.to_list n))) @@ -337,7 +354,7 @@ let mkarray n = t let ints_of_int n = - if n = 0 then [| |] + if Int.equal n 0 then [| |] else if small n then [| n |] else mkarray n @@ -346,8 +363,8 @@ let of_int n = let of_ints n = let n = normalize n in (* TODO: using normalize here seems redundant now *) - if n = zero then Obj.repr 0 else - if Array.length n = 1 then Obj.repr n.(0) else + if is_zero n then Obj.repr 0 else + if Int.equal (Array.length n) 1 then Obj.repr n.(0) else Obj.repr n let coerce_to_int = (Obj.magic : Obj.t -> int) @@ -361,7 +378,7 @@ let int_of_ints = let maxi = mkarray max_int and mini = mkarray min_int in fun t -> let l = Array.length t in - if (l > 3) || (l = 3 && (less_than maxi t || less_than t mini)) + if (l > 3) || (Int.equal l 3 && (less_than maxi t || less_than t mini)) then failwith "Bigint.to_int: too large"; let sum = ref 0 in let pow = ref 1 in @@ -379,28 +396,28 @@ let app_pair f (m, n) = (f m, f n) let add m n = - if Obj.is_int m & Obj.is_int n + if Obj.is_int m && Obj.is_int n then of_int (coerce_to_int m + coerce_to_int n) else of_ints (add (to_ints m) (to_ints n)) let sub m n = - if Obj.is_int m & Obj.is_int n + if Obj.is_int m && Obj.is_int n then of_int (coerce_to_int m - coerce_to_int n) else of_ints (sub (to_ints m) (to_ints n)) let mult m n = - if Obj.is_int m & Obj.is_int n + if Obj.is_int m && Obj.is_int n then of_int (coerce_to_int m * coerce_to_int n) else of_ints (mult (to_ints m) (to_ints n)) let euclid m n = - if Obj.is_int m & Obj.is_int n + if Obj.is_int m && Obj.is_int n then app_pair of_int (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n) else app_pair of_ints (euclid (to_ints m) (to_ints n)) let less_than m n = - if Obj.is_int m & Obj.is_int n + if Obj.is_int m && Obj.is_int n then coerce_to_int m < coerce_to_int n else less_than (to_ints m) (to_ints n) @@ -420,14 +437,17 @@ let mult_2 n = add n n let div2_with_rest n = let (q,b) = euclid n two in - (q, b = one) + (q, b == one) let is_strictly_neg n = is_strictly_neg (to_ints n) let is_strictly_pos n = is_strictly_pos (to_ints n) let is_neg_or_zero n = is_neg_or_zero (to_ints n) let is_pos_or_zero n = is_pos_or_zero (to_ints n) -let equal m n = (m = n) +let equal m n = + if Obj.is_block m && Obj.is_block n then + ArrayInt.equal (Obj.obj m) (Obj.obj n) + else m == n (* spiwack: computes n^m *) (* The basic idea of the algorithm is that n^(2m) = (n^2)^m *) @@ -441,7 +461,7 @@ let pow = odd_rest else let quo = m lsr 1 (* i.e. m/2 *) - and odd = (m land 1) <> 0 in + and odd = not (Int.equal (m land 1) 0) in pow_aux (if odd then mult n odd_rest else odd_rest) (mult n n) diff --git a/lib/bigint.mli b/lib/bigint.mli index dd2cdea6..02e3c1ad 100644 --- a/lib/bigint.mli +++ b/lib/bigint.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,6 +11,8 @@ type bigint val of_string : string -> bigint +(** May raise a Failure just as [int_of_string] on non-numerical strings *) + val to_string : bigint -> string val of_int : int -> bigint diff --git a/lib/cArray.ml b/lib/cArray.ml new file mode 100644 index 00000000..16034543 --- /dev/null +++ b/lib/cArray.ml @@ -0,0 +1,528 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +module type S = module type of Array + +module type ExtS = +sig + include S + val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int + val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool + val is_empty : 'a array -> bool + val exists : ('a -> bool) -> 'a array -> bool + val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool + val for_all : ('a -> bool) -> 'a array -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool + val for_all3 : ('a -> 'b -> 'c -> bool) -> + 'a array -> 'b array -> 'c array -> bool + val for_all4 : ('a -> 'b -> 'c -> 'd -> bool) -> + 'a array -> 'b array -> 'c array -> 'd array -> bool + val for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool + val findi : (int -> 'a -> bool) -> 'a array -> int option + val hd : 'a array -> 'a + val tl : 'a array -> 'a array + val last : 'a array -> 'a + val cons : 'a -> 'a array -> 'a array + val rev : 'a array -> unit + val fold_right_i : + (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a + val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c + val fold_left2 : + ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a + val fold_left3 : + ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a + val fold_left2_i : + (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a + val fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a + val map_to_list : ('a -> 'b) -> 'a array -> 'b list + val map_of_list : ('a -> 'b) -> 'a list -> 'b array + val chop : int -> 'a array -> 'a array * 'a array + val smartmap : ('a -> 'a) -> 'a array -> 'a array + val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array + val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array + val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array + val map3 : + ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array + val map_left : ('a -> 'b) -> 'a array -> 'b array + val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit + val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + val fold_map2' : + ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c + val distinct : 'a array -> bool + val rev_of_list : 'a list -> 'a array + val rev_to_list : 'a array -> 'a list + val filter_with : bool list -> 'a array -> 'a array +end + +include Array + +let uget = Array.unsafe_get + +(* Arrays *) + +let compare cmp v1 v2 = + if v1 == v2 then 0 + else + let len = Array.length v1 in + let c = Int.compare len (Array.length v2) in + if c <> 0 then c else + let rec loop i = + if i < 0 then 0 + else + let x = uget v1 i in + let y = uget v2 i in + let c = cmp x y in + if c <> 0 then c + else loop (i - 1) + in + loop (len - 1) + +let equal cmp t1 t2 = + if t1 == t2 then true else + let len = Array.length t1 in + if not (Int.equal len (Array.length t2)) then false + else + let rec aux i = + if i < 0 then true + else + let x = uget t1 i in + let y = uget t2 i in + cmp x y && aux (pred i) + in + aux (len - 1) + +let is_empty array = Int.equal (Array.length array) 0 + +let exists f v = + let rec exrec = function + | -1 -> false + | n -> f (uget v n) || (exrec (n-1)) + in + exrec ((Array.length v)-1) + +let exists2 f v1 v2 = + let rec exrec = function + | -1 -> false + | n -> f (uget v1 n) (uget v2 n) || (exrec (n-1)) + in + let lv1 = Array.length v1 in + lv1 = Array.length v2 && exrec (lv1-1) + +let for_all f v = + let rec allrec = function + | -1 -> true + | n -> + let ans = f (uget v n) in + ans && (allrec (n-1)) + in + allrec ((Array.length v)-1) + +let for_all2 f v1 v2 = + let rec allrec = function + | -1 -> true + | n -> + let ans = f (uget v1 n) (uget v2 n) in + ans && (allrec (n-1)) + in + let lv1 = Array.length v1 in + lv1 = Array.length v2 && allrec (pred lv1) + +let for_all3 f v1 v2 v3 = + let rec allrec = function + | -1 -> true + | n -> + let ans = f (uget v1 n) + (uget v2 n) (uget v3 n) + in + ans && (allrec (n-1)) + in + let lv1 = Array.length v1 in + lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1) + +let for_all4 f v1 v2 v3 v4 = + let rec allrec = function + | -1 -> true + | n -> + let ans = f (uget v1 n) + (uget v2 n) (uget v3 n) (uget v4 n) + in + ans && (allrec (n-1)) + in + let lv1 = Array.length v1 in + lv1 = Array.length v2 && + lv1 = Array.length v3 && + lv1 = Array.length v4 && + allrec (pred lv1) + +let for_all_i f i v = + let len = Array.length v in + let rec allrec i n = + n = len || f i (uget v n) && allrec (i+1) (n+1) in + allrec i 0 + +exception Found of int + +let findi (pred: int -> 'a -> bool) (arr: 'a array) : int option = + try + for i=0 to Array.length arr - 1 do + if pred i (uget arr i) then raise (Found i) done; + None + with Found i -> Some i + +let hd v = + match Array.length v with + | 0 -> failwith "Array.hd" + | _ -> uget v 0 + +let tl v = + match Array.length v with + | 0 -> failwith "Array.tl" + | n -> Array.sub v 1 (pred n) + +let last v = + match Array.length v with + | 0 -> failwith "Array.last" + | n -> uget v (pred n) + +let cons e v = + let len = Array.length v in + let ans = Array.make (Array.length v + 1) e in + let () = Array.blit v 0 ans 1 len in + ans + +let rev t = + let n=Array.length t in + if n <=0 then () + else + for i = 0 to pred (n/2) do + let tmp = uget t ((pred n)-i) in + Array.unsafe_set t ((pred n)-i) (uget t i); + Array.unsafe_set t i tmp + done + +let fold_right_i f v a = + let rec fold a n = + if n=0 then a + else + let k = n-1 in + fold (f k (uget v k) a) k in + fold a (Array.length v) + +let fold_left_i f v a = + let n = Array.length a in + let rec fold i v = if i = n then v else fold (succ i) (f i v (uget a i)) in + fold 0 v + +let fold_right2 f v1 v2 a = + let lv1 = Array.length v1 in + let rec fold a n = + if n=0 then a + else + let k = n-1 in + fold (f (uget v1 k) (uget v2 k) a) k in + if Array.length v2 <> lv1 then invalid_arg "Array.fold_right2"; + fold a lv1 + +let fold_left2 f a v1 v2 = + let lv1 = Array.length v1 in + let rec fold a n = + if n >= lv1 then a else fold (f a (uget v1 n) (uget v2 n)) (succ n) + in + if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2"; + fold a 0 + +let fold_left2_i f a v1 v2 = + let lv1 = Array.length v1 in + let rec fold a n = + if n >= lv1 then a else fold (f n a (uget v1 n) (uget v2 n)) (succ n) + in + if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2"; + fold a 0 + +let fold_left3 f a v1 v2 v3 = + let lv1 = Array.length v1 in + let rec fold a n = + if n >= lv1 then a + else fold (f a (uget v1 n) (uget v2 n) (uget v3 n)) (succ n) + in + if Array.length v2 <> lv1 || Array.length v3 <> lv1 then + invalid_arg "Array.fold_left2"; + fold a 0 + +let fold_left_from n f a v = + let len = Array.length v in + let () = if n < 0 then invalid_arg "Array.fold_left_from" in + let rec fold a n = + if n >= len then a else fold (f a (uget v n)) (succ n) + in + fold a n + +let rev_of_list = function +| [] -> [| |] +| x :: l -> + let len = List.length l in + let ans = Array.make (succ len) x in + let rec set i = function + | [] -> () + | x :: l -> + Array.unsafe_set ans i x; + set (pred i) l + in + let () = set (len - 1) l in + ans + +let map_to_list f v = + List.map f (Array.to_list v) + +let map_of_list f l = + let len = List.length l in + let rec fill i v = function + | [] -> () + | x :: l -> + Array.unsafe_set v i (f x); + fill (succ i) v l + in + match l with + | [] -> [||] + | x :: l -> + let ans = Array.make len (f x) in + let () = fill 1 ans l in + ans + +let chop n v = + let vlen = Array.length v in + if n > vlen then failwith "Array.chop"; + (Array.sub v 0 n, Array.sub v n (vlen-n)) + +(* If none of the elements is changed by f we return ar itself. + The while loop looks for the first such an element. + If found, we break here and the new array is produced, + but f is not re-applied to elements that are already checked *) +let smartmap f (ar : 'a array) = + let len = Array.length ar in + let i = ref 0 in + let break = ref true in + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let v' = f v in + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + (** The array is not the same as the original one *) + let ans : 'a array = Array.copy ar in + let v = match !temp with None -> assert false | Some x -> x in + Array.unsafe_set ans !i v; + incr i; + while !i < len do + let v = Array.unsafe_get ar !i in + let v' = f v in + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + ans + end else ar + +(** Same as [smartmap] but threads a state meanwhile *) +let smartfoldmap f accu (ar : 'a array) = + let len = Array.length ar in + let i = ref 0 in + let break = ref true in + let r = ref accu in + (** This variable is never accessed unset *) + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let (accu, v') = f !r v in + r := accu; + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + let ans : 'a array = Array.copy ar in + let v = match !temp with None -> assert false | Some x -> x in + Array.unsafe_set ans !i v; + incr i; + while !i < len do + let v = Array.unsafe_get ar !i in + let (accu, v') = f !r v in + r := accu; + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + !r, ans + end else !r, ar + +let map2 f v1 v2 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let () = if not (Int.equal len1 len2) then invalid_arg "Array.map2" in + if Int.equal len1 0 then + [| |] + else begin + let res = Array.make len1 (f (uget v1 0) (uget v2 0)) in + for i = 1 to pred len1 do + Array.unsafe_set res i (f (uget v1 i) (uget v2 i)) + done; + res + end + +let map2_i f v1 v2 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let () = if not (Int.equal len1 len2) then invalid_arg "Array.map2" in + if Int.equal len1 0 then + [| |] + else begin + let res = Array.make len1 (f 0 (uget v1 0) (uget v2 0)) in + for i = 1 to pred len1 do + Array.unsafe_set res i (f i (uget v1 i) (uget v2 i)) + done; + res + end + +let map3 f v1 v2 v3 = + let len1 = Array.length v1 in + let () = + if len1 <> Array.length v2 || len1 <> Array.length v3 + then invalid_arg "Array.map3" + in + if Int.equal len1 0 then + [| |] + else begin + let res = Array.make len1 (f (uget v1 0) (uget v2 0) (uget v3 0)) in + for i = 1 to pred len1 do + Array.unsafe_set res i (f (uget v1 i) (uget v2 i) (uget v3 i)) + done; + res + end + +let map_left f a = (* Ocaml does not guarantee Array.map is LR *) + let l = Array.length a in (* (even if so), then we rewrite it *) + if Int.equal l 0 then [||] else begin + let r = Array.make l (f (uget a 0)) in + for i = 1 to l - 1 do + Array.unsafe_set r i (f (uget a i)) + done; + r + end + +let iter2 f v1 v2 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in + for i = 0 to len1 - 1 do f (uget v1 i) (uget v2 i) done + +let pure_functional = false + +let fold_map' f v e = +if pure_functional then + let (l,e) = + Array.fold_right + (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) + v ([],e) in + (Array.of_list l,e) +else + let e' = ref e in + let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in + (v',!e') + +let fold_map f e v = + let e' = ref e in + let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in + (!e',v') + +let fold_map2' f v1 v2 e = + let e' = ref e in + let v' = + map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 + in + (v',!e') + + +let distinct v = + let visited = Hashtbl.create 23 in + try + Array.iter + (fun x -> + if Hashtbl.mem visited x then raise Exit + else Hashtbl.add visited x x) + v; + true + with Exit -> false + +let rev_to_list a = + let rec tolist i res = + if i >= Array.length a then res else tolist (i+1) (uget a i :: res) in + tolist 0 [] + +let filter_with filter v = + Array.of_list (CList.filter_with filter (Array.to_list v)) + +module Fun1 = +struct + + let map f arg v = match v with + | [| |] -> [| |] + | _ -> + let len = Array.length v in + let x0 = Array.unsafe_get v 0 in + let ans = Array.make len (f arg x0) in + for i = 1 to pred len do + let x = Array.unsafe_get v i in + Array.unsafe_set ans i (f arg x) + done; + ans + + let smartmap f arg (ar : 'a array) = + let len = Array.length ar in + let i = ref 0 in + let break = ref true in + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let v' = f arg v in + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + (** The array is not the same as the original one *) + let ans : 'a array = Array.copy ar in + let v = match !temp with None -> assert false | Some x -> x in + Array.unsafe_set ans !i v; + incr i; + while !i < len do + let v = Array.unsafe_get ar !i in + let v' = f arg v in + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + ans + end else ar + + let iter f arg v = + let len = Array.length v in + for i = 0 to pred len do + let x = uget v i in + f arg x + done + +end diff --git a/lib/cArray.mli b/lib/cArray.mli new file mode 100644 index 00000000..39c35e2d --- /dev/null +++ b/lib/cArray.mli @@ -0,0 +1,132 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +module type S = module type of Array + +module type ExtS = +sig + include S + val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int + (** First size comparison, then lexicographic order. *) + + val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool + (** Lift equality to array type. *) + + val is_empty : 'a array -> bool + (** True whenever the array is empty. *) + + val exists : ('a -> bool) -> 'a array -> bool + (** As [List.exists] but on arrays. *) + + val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool + + val for_all : ('a -> bool) -> 'a array -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool + val for_all3 : ('a -> 'b -> 'c -> bool) -> + 'a array -> 'b array -> 'c array -> bool + val for_all4 : ('a -> 'b -> 'c -> 'd -> bool) -> + 'a array -> 'b array -> 'c array -> 'd array -> bool + val for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool + + val findi : (int -> 'a -> bool) -> 'a array -> int option + + val hd : 'a array -> 'a + (** First element of an array, or [Failure "Array.hd"] if empty. *) + + val tl : 'a array -> 'a array + (** Remaining part of [hd], or [Failure "Array.tl"] if empty. *) + + val last : 'a array -> 'a + (** Last element of an array, or [Failure "Array.last"] if empty. *) + + val cons : 'a -> 'a array -> 'a array + (** Append an element on the left. *) + + val rev : 'a array -> unit + (** In place reversal. *) + + val fold_right_i : + (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a + val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c + val fold_left2 : + ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a + val fold_left3 : + ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a + val fold_left2_i : + (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a + val fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a + + val map_to_list : ('a -> 'b) -> 'a array -> 'b list + (** Composition of [map] and [to_list]. *) + + val map_of_list : ('a -> 'b) -> 'a list -> 'b array + (** Composition of [map] and [of_list]. *) + + val chop : int -> 'a array -> 'a array * 'a array + (** [chop i a] returns [(a1, a2)] s.t. [a = a1 + a2] and [length a1 = n]. + Raise [Failure "Array.chop"] if [i] is not a valid index. *) + + val smartmap : ('a -> 'a) -> 'a array -> 'a array + (** [smartmap f a] behaves as [map f a] but returns [a] instead of a copy when + [f x == x] for all [x] in [a]. *) + + val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array + (** Same as [smartmap] but threads an additional state left-to-right. *) + + val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array + val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array + val map3 : + ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array + + val map_left : ('a -> 'b) -> 'a array -> 'b array + (** As [map] but guaranteed to be left-to-right. *) + + val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit + (** Iter on two arrays. Raise [Invalid_argument "Array.iter2"] if sizes differ. *) + + val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + val fold_map2' : + ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c + + val distinct : 'a array -> bool + (** Return [true] if every element of the array is unique (for default + equality). *) + + val rev_of_list : 'a list -> 'a array + (** [rev_of_list l] is equivalent to [Array.of_list (List.rev l)]. *) + + val rev_to_list : 'a array -> 'a list + (** [rev_to_list a] is equivalent to [List.rev (List.of_array a)]. *) + + val filter_with : bool list -> 'a array -> 'a array + (** [filter_with b a] selects elements of [a] whose corresponding element in + [b] is [true]. Raise [Invalid_argument _] when sizes differ. *) + +end + +include ExtS + +module Fun1 : +sig + val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array + (** [Fun1.map f x v = map (f x) v] *) + + val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array + (** [Fun1.smartmap f x v = smartmap (f x) v] *) + + val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit + (** [Fun1.iter f x v = iter (f x) v] *) + +end +(** The functions defined in this module are the same as the main ones, except + that they are all higher-order, and their function arguments have an + additional parameter. This allows us to prevent closure creation in critical + cases. *) diff --git a/lib/cList.ml b/lib/cList.ml new file mode 100644 index 00000000..0ac372d8 --- /dev/null +++ b/lib/cList.ml @@ -0,0 +1,785 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +type 'a cmp = 'a -> 'a -> int +type 'a eq = 'a -> 'a -> bool + +module type S = module type of List + +module type ExtS = +sig + include S + val compare : 'a cmp -> 'a list cmp + val equal : 'a eq -> 'a list eq + val is_empty : 'a list -> bool + val init : int -> (int -> 'a) -> 'a list + val mem_f : 'a eq -> 'a -> 'a list -> bool + val add_set : 'a eq -> 'a -> 'a list -> 'a list + val eq_set : 'a eq -> 'a list -> 'a list -> bool + val intersect : 'a eq -> 'a list -> 'a list -> 'a list + val union : 'a eq -> 'a list -> 'a list -> 'a list + val unionq : 'a list -> 'a list -> 'a list + val subtract : 'a eq -> 'a list -> 'a list -> 'a list + val subtractq : 'a list -> 'a list -> 'a list + val interval : int -> int -> int list + val make : int -> 'a -> 'a list + val assign : 'a list -> int -> 'a -> 'a list + val distinct : 'a list -> bool + val distinct_f : 'a cmp -> 'a list -> bool + val duplicates : 'a eq -> 'a list -> 'a list + val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list + val map_filter : ('a -> 'b option) -> 'a list -> 'b list + val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list + val filter_with : bool list -> 'a list -> 'a list + val smartmap : ('a -> 'a) -> 'a list -> 'a list + val map_left : ('a -> 'b) -> 'a list -> 'b list + val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list + val map2_i : + (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list + val map3 : + ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list + val map4 : + ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list + val filteri : + (int -> 'a -> bool) -> 'a list -> 'a list + val smartfilter : ('a -> bool) -> 'a list -> 'a list + val index : 'a eq -> 'a -> 'a list -> int + val index0 : 'a eq -> 'a -> 'a list -> int + val iteri : (int -> 'a -> unit) -> 'a list -> unit + val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c + val fold_right_i : (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b + val fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a + val fold_right_and_left : + ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a + val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a + val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool + val except : 'a eq -> 'a -> 'a list -> 'a list + val remove : 'a eq -> 'a -> 'a list -> 'a list + val remove_first : ('a -> bool) -> 'a list -> 'a list + val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list + val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val sep_last : 'a list -> 'a * 'a list + val find_map : ('a -> 'b option) -> 'a list -> 'b + val uniquize : 'a list -> 'a list + val sort_uniquize : 'a cmp -> 'a list -> 'a list + val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + val subset : 'a list -> 'a list -> bool + val chop : int -> 'a list -> 'a list * 'a list + exception IndexOutOfRange + val goto : int -> 'a list -> 'a list * 'a list + val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list + val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list + val firstn : int -> 'a list -> 'a list + val last : 'a list -> 'a + val lastn : int -> 'a list -> 'a list + val skipn : int -> 'a list -> 'a list + val skipn_at_least : int -> 'a list -> 'a list + val addn : int -> 'a -> 'a list -> 'a list + val prefix_of : 'a eq -> 'a list -> 'a list -> bool + val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list + val drop_last : 'a list -> 'a list + val map_append : ('a -> 'b list) -> 'a list -> 'b list + val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list + val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list + val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b + val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list + val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool + val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list + val combinations : 'a list list -> 'a list list + val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list + val cartesians_filter : + ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list + val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list + + module type MonoS = sig + type elt + val equal : elt list -> elt list -> bool + val mem : elt -> elt list -> bool + val assoc : elt -> (elt * 'a) list -> 'a + val mem_assoc : elt -> (elt * 'a) list -> bool + val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list + val mem_assoc_sym : elt -> ('a * elt) list -> bool + end + +end + +include List + +(** Tail-rec implementation of usual functions. This is a well-known trick used + in, for instance, ExtLib and Batteries. *) + +type 'a cell = { + head : 'a; + mutable tail : 'a list; +} + +external cast : 'a cell -> 'a list = "%identity" + +let rec map_loop f p = function +| [] -> () +| x :: l -> + let c = { head = f x; tail = [] } in + p.tail <- cast c; + map_loop f c l + +let map f = function +| [] -> [] +| x :: l -> + let c = { head = f x; tail = [] } in + map_loop f c l; + cast c + +let rec map2_loop f p l1 l2 = match l1, l2 with +| [], [] -> () +| x :: l1, y :: l2 -> + let c = { head = f x y; tail = [] } in + p.tail <- cast c; + map2_loop f c l1 l2 +| _ -> invalid_arg "List.map2" + +let map2 f l1 l2 = match l1, l2 with +| [], [] -> [] +| x :: l1, y :: l2 -> + let c = { head = f x y; tail = [] } in + map2_loop f c l1 l2; + cast c +| _ -> invalid_arg "List.map2" + +let rec append_loop p tl = function +| [] -> p.tail <- tl +| x :: l -> + let c = { head = x; tail = [] } in + p.tail <- cast c; + append_loop c tl l + +let append l1 l2 = match l1 with +| [] -> l2 +| x :: l -> + let c = { head = x; tail = [] } in + append_loop c l2 l; + cast c + +let rec copy p = function +| [] -> p +| x :: l -> + let c = { head = x; tail = [] } in + p.tail <- cast c; + copy c l + +let rec init_loop len f p i = + if Int.equal i len then () + else + let c = { head = f i; tail = [] } in + p.tail <- cast c; + init_loop len f c (succ i) + +let init len f = + if len < 0 then invalid_arg "List.init" + else if Int.equal len 0 then [] + else + let c = { head = f 0; tail = [] } in + init_loop len f c 1; + cast c + +let rec concat_loop p = function +| [] -> () +| x :: l -> concat_loop (copy p x) l + +let concat l = + let dummy = { head = Obj.magic 0; tail = [] } in + concat_loop dummy l; + dummy.tail + +let flatten = concat + +let rec split_loop p q = function +| [] -> () +| (x, y) :: l -> + let cl = { head = x; tail = [] } in + let cr = { head = y; tail = [] } in + p.tail <- cast cl; + q.tail <- cast cr; + split_loop cl cr l + +let split = function +| [] -> [], [] +| (x, y) :: l -> + let cl = { head = x; tail = [] } in + let cr = { head = y; tail = [] } in + split_loop cl cr l; + (cast cl, cast cr) + +let rec combine_loop p l1 l2 = match l1, l2 with +| [], [] -> () +| x :: l1, y :: l2 -> + let c = { head = (x, y); tail = [] } in + p.tail <- cast c; + combine_loop c l1 l2 +| _ -> invalid_arg "List.combine" + +let combine l1 l2 = match l1, l2 with +| [], [] -> [] +| x :: l1, y :: l2 -> + let c = { head = (x, y); tail = [] } in + combine_loop c l1 l2; + cast c +| _ -> invalid_arg "List.combine" + +let rec filter_loop f p = function +| [] -> () +| x :: l -> + if f x then + let c = { head = x; tail = [] } in + let () = p.tail <- cast c in + filter_loop f c l + else + filter_loop f p l + +let filter f l = + let c = { head = Obj.magic 0; tail = [] } in + filter_loop f c l; + c.tail + +(** FIXME: Already present in OCaml 4.00 *) + +let rec map_i_loop f i p = function +| [] -> () +| x :: l -> + let c = { head = f i x; tail = [] } in + p.tail <- cast c; + map_i_loop f (succ i) c l + +let map_i f i = function +| [] -> [] +| x :: l -> + let c = { head = f i x; tail = [] } in + map_i_loop f (succ i) c l; + cast c + +(** Extensions of OCaml Stdlib *) + +let rec compare cmp l1 l2 = + if l1 == l2 then 0 else + match l1,l2 with + [], [] -> 0 + | _::_, [] -> 1 + | [], _::_ -> -1 + | x1::l1, x2::l2 -> + (match cmp x1 x2 with + | 0 -> compare cmp l1 l2 + | c -> c) + +let rec equal cmp l1 l2 = + l1 == l2 || + match l1, l2 with + | [], [] -> true + | x1 :: l1, x2 :: l2 -> + cmp x1 x2 && equal cmp l1 l2 + | _ -> false + +let is_empty = function +| [] -> true +| _ -> false + +let mem_f cmp x l = List.exists (cmp x) l + +let intersect cmp l1 l2 = + filter (fun x -> mem_f cmp x l2) l1 + +let union cmp l1 l2 = + let rec urec = function + | [] -> l2 + | a::l -> if mem_f cmp a l2 then urec l else a::urec l + in + urec l1 + +let subtract cmp l1 l2 = + if is_empty l2 then l1 + else List.filter (fun x -> not (mem_f cmp x l2)) l1 + +let unionq l1 l2 = union (==) l1 l2 +let subtractq l1 l2 = subtract (==) l1 l2 + +let interval n m = + let rec interval_n (l,m) = + if n > m then l else interval_n (m::l, pred m) + in + interval_n ([], m) + +let addn n v = + let rec aux n l = + if Int.equal n 0 then l + else aux (pred n) (v :: l) + in + if n < 0 then invalid_arg "List.addn" + else aux n + +let make n v = addn n v [] + +let assign l n e = + let rec assrec stk l i = match l, i with + | ((h::t), 0) -> List.rev_append stk (e :: t) + | ((h::t), n) -> assrec (h :: stk) t (pred n) + | ([], _) -> failwith "List.assign" + in + assrec [] l n + +let rec smartmap f l = match l with + [] -> l + | h::tl -> + let h' = f h and tl' = smartmap f tl in + if h'==h && tl'==tl then l + else h'::tl' + +let map_left = map + +let map2_i f i l1 l2 = + let rec map_i i = function + | ([], []) -> [] + | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2) + | (_, _) -> invalid_arg "map2_i" + in + map_i i (l1,l2) + +let map3 f l1 l2 l3 = + let rec map = function + | ([], [], []) -> [] + | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3) + | (_, _, _) -> invalid_arg "map3" + in + map (l1,l2,l3) + +let map4 f l1 l2 l3 l4 = + let rec map = function + | ([], [], [], []) -> [] + | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4) + | (_, _, _, _) -> invalid_arg "map4" + in + map (l1,l2,l3,l4) + +let rec smartfilter f l = match l with + [] -> l + | h::tl -> + let tl' = smartfilter f tl in + if f h then + if tl' == tl then l + else h :: tl' + else tl' + +let rec index_f f x l n = match l with +| [] -> raise Not_found +| y :: l -> if f x y then n else index_f f x l (succ n) + +let index f x l = index_f f x l 1 + +let index0 f x l = index_f f x l 0 + +let fold_left_until f accu s = + let rec aux accu = function + | [] -> accu + | x :: xs -> match f accu x with CSig.Stop x -> x | CSig.Cont i -> aux i xs in + aux accu s + +let fold_right_i f i l = + let rec it_f i l a = match l with + | [] -> a + | b::l -> f (i-1) b (it_f (i-1) l a) + in + it_f (List.length l + i) l + +let fold_left_i f = + let rec it_list_f i a = function + | [] -> a + | b::l -> it_list_f (i+1) (f i a b) l + in + it_list_f + +let rec fold_left3 f accu l1 l2 l3 = + match (l1, l2, l3) with + ([], [], []) -> accu + | (a1::l1, a2::l2, a3::l3) -> fold_left3 f (f accu a1 a2 a3) l1 l2 l3 + | (_, _, _) -> invalid_arg "List.fold_left3" + +(* [fold_right_and_left f [a1;...;an] hd = + f (f (... (f (f hd + an + [an-1;...;a1]) + an-1 + [an-2;...;a1]) + ...) + a2 + [a1]) + a1 + []] *) + +let fold_right_and_left f l hd = + let rec aux tl = function + | [] -> hd + | a::l -> let hd = aux (a::tl) l in f hd a tl + in aux [] l + +let iteri f l = fold_left_i (fun i _ x -> f i x) 0 () l + +let for_all_i p = + let rec for_all_p i = function + | [] -> true + | a::l -> p i a && for_all_p (i+1) l + in + for_all_p + +let except cmp x l = List.filter (fun y -> not (cmp x y)) l + +let remove = except (* Alias *) + +let rec remove_first p = function + | b::l when p b -> l + | b::l -> b::remove_first p l + | [] -> raise Not_found + +let insert p v l = + let rec insrec = function + | [] -> [v] + | h::tl -> if p v h then v::h::tl else h::insrec tl + in + insrec l + +let add_set cmp x l = if mem_f cmp x l then l else x :: l + +(** List equality up to permutation (but considering multiple occurrences) *) + +let eq_set cmp l1 l2 = + let rec aux l1 = function + | [] -> is_empty l1 + | a::l2 -> aux (remove_first (cmp a) l1) l2 in + try aux l1 l2 with Not_found -> false + +let for_all2eq f l1 l2 = + try List.for_all2 f l1 l2 with Invalid_argument _ -> false + +let filteri p = + let rec filter_i_rec i = function + | [] -> [] + | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l' + in + filter_i_rec 0 + +let rec sep_last = function + | [] -> failwith "sep_last" + | hd::[] -> (hd,[]) + | hd::tl -> let (l,tl) = sep_last tl in (l,hd::tl) + +let rec find_map f = function +| [] -> raise Not_found +| x :: l -> + match f x with + | None -> find_map f l + | Some y -> y + +(* FIXME: we should avoid relying on the generic hash function, + just as we'd better avoid Pervasives.compare *) + +let uniquize l = + let visited = Hashtbl.create 23 in + let rec aux acc changed = function + | h::t -> if Hashtbl.mem visited h then aux acc true t else + begin + Hashtbl.add visited h h; + aux (h::acc) changed t + end + | [] -> if changed then List.rev acc else l + in aux [] false l + +(** [sort_uniquize] might be an alternative to the hashtbl-based + [uniquize], when the order of the elements is irrelevant *) + +let rec uniquize_sorted cmp = function + | a::b::l when Int.equal (cmp a b) 0 -> uniquize_sorted cmp (a::l) + | a::l -> a::uniquize_sorted cmp l + | [] -> [] + +let sort_uniquize cmp l = uniquize_sorted cmp (List.sort cmp l) + +(* FIXME: again, generic hash function *) + +let distinct l = + let visited = Hashtbl.create 23 in + let rec loop = function + | h::t -> + if Hashtbl.mem visited h then false + else + begin + Hashtbl.add visited h h; + loop t + end + | [] -> true + in loop l + +let distinct_f cmp l = + let rec loop = function + | a::b::_ when Int.equal (cmp a b) 0 -> false + | a::l -> loop l + | [] -> true + in loop (List.sort cmp l) + +let rec merge_uniq cmp l1 l2 = + match l1, l2 with + | [], l2 -> l2 + | l1, [] -> l1 + | h1 :: t1, h2 :: t2 -> + let c = cmp h1 h2 in + if Int.equal c 0 + then h1 :: merge_uniq cmp t1 t2 + else if c <= 0 + then h1 :: merge_uniq cmp t1 l2 + else h2 :: merge_uniq cmp l1 t2 + +let rec duplicates cmp = function + | [] -> [] + | x::l -> + let l' = duplicates cmp l in + if mem_f cmp x l then add_set cmp x l' else l' + +let rec filter2_loop f p q l1 l2 = match l1, l2 with +| [], [] -> () +| x :: l1, y :: l2 -> + if f x y then + let c1 = { head = x; tail = [] } in + let c2 = { head = y; tail = [] } in + let () = p.tail <- cast c1 in + let () = q.tail <- cast c2 in + filter2_loop f c1 c2 l1 l2 + else + filter2_loop f p q l1 l2 +| _ -> invalid_arg "List.filter2" + +let filter2 f l1 l2 = + let c1 = { head = Obj.magic 0; tail = [] } in + let c2 = { head = Obj.magic 0; tail = [] } in + filter2_loop f c1 c2 l1 l2; + (c1.tail, c2.tail) + +let rec map_filter f = function + | [] -> [] + | x::l -> + let l' = map_filter f l in + match f x with None -> l' | Some y -> y::l' + +let map_filter_i f = + let rec aux i = function + | [] -> [] + | x::l -> + let l' = aux (succ i) l in + match f i x with None -> l' | Some y -> y::l' + in aux 0 + +let rec filter_with filter l = match filter, l with +| [], [] -> [] +| true :: filter, x :: l -> x :: filter_with filter l +| false :: filter, _ :: l -> filter_with filter l +| _ -> invalid_arg "List.filter_with" + +(* FIXME: again, generic hash function *) + +let subset l1 l2 = + let t2 = Hashtbl.create 151 in + List.iter (fun x -> Hashtbl.add t2 x ()) l2; + let rec look = function + | [] -> true + | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false + in + look l1 + +(** [goto i l] splits [l] into two lists [(l1,l2)] such that + [(List.rev l1)++l2=l] and [l1] has length [i]. It raises + [IndexOutOfRange] when [i] is negative or greater than the + length of [l]. *) +exception IndexOutOfRange +let goto n l = + let rec goto i acc = function + | tl when Int.equal i 0 -> (acc, tl) + | h::t -> goto (pred i) (h::acc) t + | [] -> raise IndexOutOfRange + in + goto n [] l + +(* [chop i l] splits [l] into two lists [(l1,l2)] such that + [l1++l2=l] and [l1] has length [i]. + It raises [Failure] when [i] is negative or greater than the length of [l] *) + +let chop n l = + try let (h,t) = goto n l in (List.rev h,t) + with IndexOutOfRange -> failwith "List.chop" + (* spiwack: should raise [IndexOutOfRange] but I'm afraid of missing + a try/with when replacing the exception. *) + +(* [split_when p l] splits [l] into two lists [(l1,a::l2)] such that + [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1]. + If there is no such [a], then it returns [(l,[])] instead *) +let split_when p = + let rec split_when_loop x y = + match y with + | [] -> (List.rev x,[]) + | (a::l) -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l + in + split_when_loop [] + +let rec split3 = function + | [] -> ([], [], []) + | (x,y,z)::l -> + let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz) + +let firstn n l = + let rec aux acc = function + | (0, l) -> List.rev acc + | (n, (h::t)) -> aux (h::acc) (pred n, t) + | _ -> failwith "firstn" + in + aux [] (n,l) + +let rec last = function + | [] -> failwith "List.last" + | [x] -> x + | _ :: l -> last l + +let lastn n l = + let len = List.length l in + let rec aux m l = + if Int.equal m n then l else aux (m - 1) (List.tl l) + in + if len < n then failwith "lastn" else aux len l + +let rec skipn n l = match n,l with + | 0, _ -> l + | _, [] -> failwith "List.skipn" + | n, _::l -> skipn (pred n) l + +let skipn_at_least n l = + try skipn n l with Failure _ -> [] + +let prefix_of cmp prefl l = + let rec prefrec = function + | (h1::t1, h2::t2) -> cmp h1 h2 && prefrec (t1,t2) + | ([], _) -> true + | _ -> false + in + prefrec (prefl,l) + +(** if [l=p++t] then [drop_prefix p l] is [t] else [l] *) + +let drop_prefix cmp p l = + let rec drop_prefix_rec = function + | (h1::tp, h2::tl) when cmp h1 h2 -> drop_prefix_rec (tp,tl) + | ([], tl) -> tl + | _ -> l + in + drop_prefix_rec (p,l) + +let map_append f l = List.flatten (List.map f l) + +let map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2) + +let share_tails l1 l2 = + let rec shr_rev acc = function + | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2) + | (l1,l2) -> (List.rev l1, List.rev l2, acc) + in + shr_rev [] (List.rev l1, List.rev l2) + +let rec fold_map f e = function + | [] -> (e,[]) + | h::t -> + let e',h' = f e h in + let e'',t' = fold_map f e' t in + e'',h'::t' + +(* (* tail-recursive version of the above function *) +let fold_map f e l = + let g (e,b') h = + let (e',h') = f e h in + (e',h'::b') + in + let (e',lrev) = List.fold_left g (e,[]) l in + (e',List.rev lrev) +*) + +(* The same, based on fold_right, with the effect accumulated on the right *) +let fold_map' f l e = + List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e) + +let map_assoc f = List.map (fun (x,a) -> (x,f a)) + +let rec assoc_f f a = function + | (x, e) :: xs -> if f a x then e else assoc_f f a xs + | [] -> raise Not_found + +let remove_assoc_f f a l = + try remove_first (fun (x,_) -> f a x) l with Not_found -> l + +let mem_assoc_f f a l = List.exists (fun (x,_) -> f a x) l + +(* A generic cartesian product: for any operator (**), + [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], + and so on if there are more elements in the lists. *) + +let cartesian op l1 l2 = + map_append (fun x -> List.map (op x) l2) l1 + +(* [cartesians] is an n-ary cartesian product: it iterates + [cartesian] over a list of lists. *) + +let cartesians op init ll = + List.fold_right (cartesian op) ll [init] + +(* combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *) + +let combinations l = cartesians (fun x l -> x::l) [] l + +let rec combine3 x y z = + match x, y, z with + | [], [], [] -> [] + | (x :: xs), (y :: ys), (z :: zs) -> + (x, y, z) :: combine3 xs ys zs + | _, _, _ -> invalid_arg "List.combine3" + +(* Keep only those products that do not return None *) + +let cartesian_filter op l1 l2 = + map_append (fun x -> map_filter (op x) l2) l1 + +(* Keep only those products that do not return None *) + +let cartesians_filter op init ll = + List.fold_right (cartesian_filter op) ll [init] + +(* Drop the last element of a list *) + +let rec drop_last = function + | [] -> assert false + | hd :: [] -> [] + | hd :: tl -> hd :: drop_last tl + +(* Factorize lists of pairs according to the left argument *) +let rec factorize_left cmp = function + | (a,b)::l -> + let al,l' = partition (fun (a',_) -> cmp a a') l in + (a,(b::List.map snd al)) :: factorize_left cmp l' + | [] -> [] + +module type MonoS = sig + type elt + val equal : elt list -> elt list -> bool + val mem : elt -> elt list -> bool + val assoc : elt -> (elt * 'a) list -> 'a + val mem_assoc : elt -> (elt * 'a) list -> bool + val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list + val mem_assoc_sym : elt -> ('a * elt) list -> bool +end diff --git a/lib/cList.mli b/lib/cList.mli new file mode 100644 index 00000000..19eeb250 --- /dev/null +++ b/lib/cList.mli @@ -0,0 +1,229 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +type 'a cmp = 'a -> 'a -> int +type 'a eq = 'a -> 'a -> bool + +(** Module type [S] is the one from OCaml Stdlib. *) +module type S = module type of List + +module type ExtS = +sig + include S + + val compare : 'a cmp -> 'a list cmp + (** Lexicographic order on lists. *) + + val equal : 'a eq -> 'a list eq + (** Lifts equality to list type. *) + + val is_empty : 'a list -> bool + (** Checks whether a list is empty *) + + val init : int -> (int -> 'a) -> 'a list + (** [init n f] constructs the list [f 0; ... ; f (n - 1)]. *) + + val mem_f : 'a eq -> 'a -> 'a list -> bool + (* Same as [List.mem], for some specific equality *) + + val add_set : 'a eq -> 'a -> 'a list -> 'a list + (** [add_set x l] adds [x] in [l] if it is not already there, or returns [l] + otherwise. *) + + val eq_set : 'a eq -> 'a list eq + (** Test equality up to permutation (but considering multiple occurrences) *) + + val intersect : 'a eq -> 'a list -> 'a list -> 'a list + val union : 'a eq -> 'a list -> 'a list -> 'a list + val unionq : 'a list -> 'a list -> 'a list + val subtract : 'a eq -> 'a list -> 'a list -> 'a list + val subtractq : 'a list -> 'a list -> 'a list + + val interval : int -> int -> int list + (** [interval i j] creates the list [[i; i + 1; ...; j]], or [[]] when + [j <= i]. *) + + val make : int -> 'a -> 'a list + (** [make n x] returns a list made of [n] times [x]. Raise + [Invalid_argument "List.make"] if [n] is negative. *) + + val assign : 'a list -> int -> 'a -> 'a list + (** [assign l i x] set the [i]-th element of [l] to [x], starting from [0]. *) + + val distinct : 'a list -> bool + (** Return [true] if all elements of the list are distinct. *) + + val distinct_f : 'a cmp -> 'a list -> bool + + val duplicates : 'a eq -> 'a list -> 'a list + (** Return the list of unique elements which appear at least twice. Elements + are kept in the order of their first appearance. *) + + val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list + val map_filter : ('a -> 'b option) -> 'a list -> 'b list + val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list + + val filter_with : bool list -> 'a list -> 'a list + (** [filter_with b a] selects elements of [a] whose corresponding element in + [b] is [true]. Raise [Invalid_argument _] when sizes differ. *) + + val smartmap : ('a -> 'a) -> 'a list -> 'a list + (** [smartmap f [a1...an] = List.map f [a1...an]] but if for all i + [f ai == ai], then [smartmap f l == l] *) + + val map_left : ('a -> 'b) -> 'a list -> 'b list + (** As [map] but ensures the left-to-right order of evaluation. *) + + val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list + (** As [map] but with the index, which starts from [0]. *) + + val map2_i : + (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list + val map3 : + ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list + val map4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> + 'd list -> 'e list + val filteri : (int -> 'a -> bool) -> 'a list -> 'a list + + val smartfilter : ('a -> bool) -> 'a list -> 'a list + (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i + [f ai = true], then [smartfilter f l == l] *) + + val index : 'a eq -> 'a -> 'a list -> int + (** [index] returns the 1st index of an element in a list (counting from 1). *) + + val index0 : 'a eq -> 'a -> 'a list -> int + (** [index0] behaves as [index] except that it starts counting at 0. *) + + val iteri : (int -> 'a -> unit) -> 'a list -> unit + (** As [iter] but with the index argument (starting from 0). *) + + val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c + (** acts like [fold_left f acc s] while [f] returns + [Cont acc']; it stops returning [c] as soon as [f] returns [Stop c]. *) + + val fold_right_i : (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b + val fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a + val fold_right_and_left : + ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a + val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a + val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool + val except : 'a eq -> 'a -> 'a list -> 'a list + val remove : 'a eq -> 'a -> 'a list -> 'a list + + val remove_first : ('a -> bool) -> 'a list -> 'a list + (** Remove the first element satisfying a predicate, or raise [Not_found] *) + + val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list + (** Insert at the (first) position so that if the list is ordered wrt to the + total order given as argument, the order is preserved *) + + val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val sep_last : 'a list -> 'a * 'a list + + val find_map : ('a -> 'b option) -> 'a list -> 'b + (** Returns the first element that is mapped to [Some _]. Raise [Not_found] if + there is none. *) + + val uniquize : 'a list -> 'a list + (** Return the list of elements without duplicates. + This is the list unchanged if there was none. *) + + val sort_uniquize : 'a cmp -> 'a list -> 'a list + (** Return a sorted and de-duplicated version of a list, + according to some comparison function. *) + + val merge_uniq : 'a cmp -> 'a list -> 'a list -> 'a list + (** Merge two sorted lists and preserves the uniqueness property. *) + + val subset : 'a list -> 'a list -> bool + + val chop : int -> 'a list -> 'a list * 'a list + (** [chop i l] splits [l] into two lists [(l1,l2)] such that + [l1++l2=l] and [l1] has length [i]. It raises [Failure] when [i] + is negative or greater than the length of [l] *) + + exception IndexOutOfRange + val goto: int -> 'a list -> 'a list * 'a list + (** [goto i l] splits [l] into two lists [(l1,l2)] such that + [(List.rev l1)++l2=l] and [l1] has length [i]. It raises + [IndexOutOfRange] when [i] is negative or greater than the + length of [l]. *) + + + val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list + val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list + val firstn : int -> 'a list -> 'a list + val last : 'a list -> 'a + val lastn : int -> 'a list -> 'a list + val skipn : int -> 'a list -> 'a list + val skipn_at_least : int -> 'a list -> 'a list + + val addn : int -> 'a -> 'a list -> 'a list + (** [addn n x l] adds [n] times [x] on the left of [l]. *) + + val prefix_of : 'a eq -> 'a list -> 'a list -> bool + (** [prefix_of l1 l2] returns [true] if [l1] is a prefix of [l2], [false] + otherwise. *) + + val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list + (** [drop_prefix p l] returns [t] if [l=p++t] else return [l]. *) + + val drop_last : 'a list -> 'a list + + val map_append : ('a -> 'b list) -> 'a list -> 'b list + (** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)]. *) + + val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list + (** As [map_append]. Raises [Invalid_argument _] if the two lists don't have + the same length. *) + + val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list + + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + (** [fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]] + where [(e_i,k_i)=f e_{i-1} l_i] *) + + val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list + val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b + val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list + val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool + + val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + (** A generic cartesian product: for any operator (**), + [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], + and so on if there are more elements in the lists. *) + + val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list + (** [cartesians] is an n-ary cartesian product: it iterates + [cartesian] over a list of lists. *) + + val combinations : 'a list list -> 'a list list + (** combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *) + + val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list + + val cartesians_filter : + ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list + (** Keep only those products that do not return None *) + + val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list + + module type MonoS = sig + type elt + val equal : elt list -> elt list -> bool + val mem : elt -> elt list -> bool + val assoc : elt -> (elt * 'a) list -> 'a + val mem_assoc : elt -> (elt * 'a) list -> bool + val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list + val mem_assoc_sym : elt -> ('a * elt) list -> bool + end +end + +include ExtS diff --git a/lib/cMap.ml b/lib/cMap.ml new file mode 100644 index 00000000..cf590d96 --- /dev/null +++ b/lib/cMap.ml @@ -0,0 +1,168 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module type OrderedType = +sig + type t + val compare : t -> t -> int +end + +module type S = Map.S + +module type ExtS = +sig + include Map.S + module Set : CSig.SetS with type elt = key + val update : key -> 'a -> 'a t -> 'a t + val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t + val domain : 'a t -> Set.t + val bind : (key -> 'a) -> Set.t -> 'a t + val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val smartmap : ('a -> 'a) -> 'a t -> 'a t + val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t + module Unsafe : + sig + val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t + end +end + +module MapExt (M : Map.OrderedType) : +sig + type 'a map = 'a Map.Make(M).t + val update : M.t -> 'a -> 'a map -> 'a map + val modify : M.t -> (M.t -> 'a -> 'a) -> 'a map -> 'a map + val domain : 'a map -> Set.Make(M).t + val bind : (M.t -> 'a) -> Set.Make(M).t -> 'a map + val fold_left : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b + val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b + val smartmap : ('a -> 'a) -> 'a map -> 'a map + val smartmapi : (M.t -> 'a -> 'a) -> 'a map -> 'a map + module Unsafe : + sig + val map : (M.t -> 'a -> M.t * 'b) -> 'a map -> 'b map + end +end = +struct + (** This unsafe module is a way to access to the actual implementations of + OCaml sets and maps without reimplementing them ourselves. It is quite + dubious that these implementations will ever be changed... Nonetheless, + if this happens, we can still implement a less clever version of [domain]. + *) + + type 'a map = 'a Map.Make(M).t + type set = Set.Make(M).t + + type 'a _map = + | MEmpty + | MNode of 'a map * M.t * 'a * 'a map * int + + type _set = + | SEmpty + | SNode of set * M.t * set * int + + let map_prj : 'a map -> 'a _map = Obj.magic + let map_inj : 'a _map -> 'a map = Obj.magic + let set_prj : set -> _set = Obj.magic + let set_inj : _set -> set = Obj.magic + + let rec update k v (s : 'a map) : 'a map = match map_prj s with + | MEmpty -> raise Not_found + | MNode (l, k', v', r, h) -> + let c = M.compare k k' in + if c < 0 then + let l' = update k v l in + if l == l' then s + else map_inj (MNode (l', k', v', r, h)) + else if c = 0 then + if v' == v then s + else map_inj (MNode (l, k', v, r, h)) + else + let r' = update k v r in + if r == r' then s + else map_inj (MNode (l, k', v', r', h)) + + let rec modify k f (s : 'a map) : 'a map = match map_prj s with + | MEmpty -> raise Not_found + | MNode (l, k', v, r, h) -> + let c = M.compare k k' in + if c < 0 then + let l' = modify k f l in + if l == l' then s + else map_inj (MNode (l', k', v, r, h)) + else if c = 0 then + let v' = f k' v in + if v' == v then s + else map_inj (MNode (l, k', v', r, h)) + else + let r' = modify k f r in + if r == r' then s + else map_inj (MNode (l, k', v, r', h)) + + let rec domain (s : 'a map) : set = match map_prj s with + | MEmpty -> set_inj SEmpty + | MNode (l, k, _, r, h) -> + set_inj (SNode (domain l, k, domain r, h)) + (** This function is essentially identity, but OCaml current stdlib does not + take advantage of the similarity of the two structures, so we introduce + this unsafe loophole. *) + + let rec bind f (s : set) : 'a map = match set_prj s with + | SEmpty -> map_inj MEmpty + | SNode (l, k, r, h) -> + map_inj (MNode (bind f l, k, f k, bind f r, h)) + (** Dual operation of [domain]. *) + + let rec fold_left f (s : 'a map) accu = match map_prj s with + | MEmpty -> accu + | MNode (l, k, v, r, h) -> + let accu = f k v (fold_left f l accu) in + fold_left f r accu + + let rec fold_right f (s : 'a map) accu = match map_prj s with + | MEmpty -> accu + | MNode (l, k, v, r, h) -> + let accu = f k v (fold_right f r accu) in + fold_right f l accu + + let rec smartmap f (s : 'a map) = match map_prj s with + | MEmpty -> map_inj MEmpty + | MNode (l, k, v, r, h) -> + let l' = smartmap f l in + let r' = smartmap f r in + let v' = f v in + if l == l' && r == r' && v == v' then s + else map_inj (MNode (l', k, v', r', h)) + + let rec smartmapi f (s : 'a map) = match map_prj s with + | MEmpty -> map_inj MEmpty + | MNode (l, k, v, r, h) -> + let l' = smartmapi f l in + let r' = smartmapi f r in + let v' = f k v in + if l == l' && r == r' && v == v' then s + else map_inj (MNode (l', k, v', r', h)) + + module Unsafe = + struct + + let rec map f (s : 'a map) : 'b map = match map_prj s with + | MEmpty -> map_inj MEmpty + | MNode (l, k, v, r, h) -> + let (k, v) = f k v in + map_inj (MNode (map f l, k, v, map f r, h)) + + end + +end + +module Make(M : Map.OrderedType) = +struct + include Map.Make(M) + include MapExt(M) +end diff --git a/lib/cMap.mli b/lib/cMap.mli new file mode 100644 index 00000000..23d3801e --- /dev/null +++ b/lib/cMap.mli @@ -0,0 +1,67 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** {5 Extended version of OCaml's maps} *) + +module type OrderedType = +sig + type t + val compare : t -> t -> int +end + +module type S = Map.S + +module type ExtS = +sig + include Map.S + (** The underlying Map library *) + + module Set : CSig.SetS with type elt = key + (** Sets used by the domain function *) + + val update : key -> 'a -> 'a t -> 'a t + (** Same as [add], but expects the key to be present, and thus faster. + @raise Not_found when the key is unbound in the map. *) + + val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t + (** Apply the given function to the binding of the given key. + @raise Not_found when the key is unbound in the map. *) + + val domain : 'a t -> Set.t + (** Recover the set of keys defined in the map. *) + + val bind : (key -> 'a) -> Set.t -> 'a t + (** [bind f s] transform the set [x1; ...; xn] into [x1 := f x1; ...; + xn := f xn]. *) + + val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** Alias for {!fold}, to easily track where we depend on fold order. *) + + val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** Folding keys in decreasing order. *) + + val smartmap : ('a -> 'a) -> 'a t -> 'a t + (** As [map] but tries to preserve sharing. *) + + val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t + (** As [mapi] but tries to preserve sharing. *) + + module Unsafe : + sig + val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t + (** As the usual [map], but also allows modifying the key of a binding. + It is required that the mapping function [f] preserves key equality, + i.e.: for all (k : key) (x : 'a), compare (fst (f k x)) k = 0. *) + end + +end + +module Make(M : Map.OrderedType) : ExtS with + type key = M.t + and type 'a t = 'a Map.Make(M).t + and module Set := Set.Make(M) diff --git a/lib/cObj.ml b/lib/cObj.ml new file mode 100644 index 00000000..7f3ee185 --- /dev/null +++ b/lib/cObj.ml @@ -0,0 +1,203 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(*s Logical and physical size of ocaml values. *) + +(** {6 Logical sizes} *) + +let c = ref 0 +let s = ref 0 +let b = ref 0 +let m = ref 0 + +let rec obj_stats d t = + if Obj.is_int t then m := max d !m + else if Obj.tag t >= Obj.no_scan_tag then + if Obj.tag t = Obj.string_tag then + (c := !c + Obj.size t; b := !b + 1; m := max d !m) + else if Obj.tag t = Obj.double_tag then + (s := !s + 2; b := !b + 1; m := max d !m) + else if Obj.tag t = Obj.double_array_tag then + (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m) + else (b := !b + 1; m := max d !m) + else + let n = Obj.size t in + s := !s + n; b := !b + 1; + block_stats (d + 1) (n - 1) t + +and block_stats d i t = + if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t) + +let obj_stats a = + c := 0; s:= 0; b:= 0; m:= 0; + obj_stats 0 (Obj.repr a); + (!c, !s + !b, !m) + +(** {6 Physical sizes} *) + +(*s Pointers already visited are stored in a hash-table, where + comparisons are done using physical equality. *) + +module H = Hashtbl.Make( + struct + type t = Obj.t + let equal = (==) + let hash = Hashtbl.hash + end) + +let node_table = (H.create 257 : unit H.t) + +let in_table o = try H.find node_table o; true with Not_found -> false + +let add_in_table o = H.add node_table o () + +let reset_table () = H.clear node_table + +(*s Objects are traversed recursively, as soon as their tags are less than + [no_scan_tag]. [count] records the numbers of words already visited. *) + +let size_of_double = Obj.size (Obj.repr 1.0) + +let count = ref 0 + +let rec traverse t = + if not (in_table t) && Obj.is_block t then begin + add_in_table t; + let n = Obj.size t in + let tag = Obj.tag t in + if tag < Obj.no_scan_tag then + begin + count := !count + 1 + n; + for i = 0 to n - 1 do traverse (Obj.field t i) done + end + else if tag = Obj.string_tag then + count := !count + 1 + n + else if tag = Obj.double_tag then + count := !count + size_of_double + else if tag = Obj.double_array_tag then + count := !count + 1 + size_of_double * n + else + incr count + end + +(*s Sizes of objects in words and in bytes. The size in bytes is computed + system-independently according to [Sys.word_size]. *) + +let size o = + reset_table (); + count := 0; + traverse (Obj.repr o); + !count + +let size_b o = (size o) * (Sys.word_size / 8) + +let size_kb o = (size o) / (8192 / Sys.word_size) + +(** {6 Physical sizes with sharing} *) + +(** This time, all the size of objects are computed with respect + to a larger object containing them all, and we only count + the new blocks not already seen earlier in the left-to-right + visit of the englobing object. + + The very same object could have a zero size or not, depending + of the occurrence we're considering in the englobing object. + For speaking of occurrences, we use an [int list] for a path + of field indexes from the outmost block to the one we're looking. + In the list, the leftmost integer is the field index in the deepest + block. +*) + +(** We now store in the hashtable the size (with sharing), and + also the position of the first occurrence of the object *) + +let node_sizes = (H.create 257 : (int*int list) H.t) +let get_size o = H.find node_sizes o +let add_size o n pos = H.replace node_sizes o (n,pos) +let reset_sizes () = H.clear node_sizes +let global_object = ref (Obj.repr 0) + +(** [sum n f] is [f 0 + f 1 + ... + f (n-1)], evaluated from left to right *) + +let sum n f = + let rec loop k acc = if k >= n then acc else loop (k+1) (acc + f k) + in loop 0 0 + +(** Recursive visit of the main object, filling the hashtable *) + +let rec compute_size o pos = + if not (Obj.is_block o) then 0 + else + try + let _ = get_size o in 0 (* already seen *) + with Not_found -> + let n = Obj.size o in + add_size o (-1) pos (* temp size, for cyclic values *); + let tag = Obj.tag o in + let size = + if tag < Obj.no_scan_tag then + 1 + n + sum n (fun i -> compute_size (Obj.field o i) (i::pos)) + else if tag = Obj.string_tag then + 1 + n + else if tag = Obj.double_tag then + size_of_double + else if tag = Obj.double_array_tag then + size_of_double * n + else + 1 + in + add_size o size pos; + size + +(** Provides the global object in which we'll search shared sizes *) + +let register_shared_size t = + let o = Obj.repr t in + reset_sizes (); + global_object := o; + ignore (compute_size o []) + +(** Shared size of an object with respect to the global object given + by the last [register_shared_size] *) + +let shared_size pos o = + if not (Obj.is_block o) then 0 + else + let size,pos' = + try get_size o + with Not_found -> failwith "shared_size: unregistered structure ?" + in + match pos with + | Some p when p <> pos' -> 0 + | _ -> size + +let shared_size_of_obj t = shared_size None (Obj.repr t) + +(** Shared size of the object at some positiion in the global object given + by the last [register_shared_size] *) + +let shared_size_of_pos pos = + let rec obj_of_pos o = function + | [] -> o + | n::pos' -> + let o' = obj_of_pos o pos' in + assert (Obj.is_block o' && n < Obj.size o'); + Obj.field o' n + in + shared_size (Some pos) (obj_of_pos !global_object pos) + + +(*s Total size of the allocated ocaml heap. *) + +let heap_size () = + let stat = Gc.stat () + and control = Gc.get () in + let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in + (max_words_total * (Sys.word_size / 8)) + +let heap_size_kb () = (heap_size () + 1023) / 1024 diff --git a/lib/cObj.mli b/lib/cObj.mli new file mode 100644 index 00000000..16933a4a --- /dev/null +++ b/lib/cObj.mli @@ -0,0 +1,59 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** {6 Physical size of an ocaml value.} + + These functions explore objects recursively and may allocate a lot. *) + +val size : 'a -> int +(** Physical size of an object in words. *) + +val size_b : 'a -> int +(** Same as [size] in bytes. *) + +val size_kb : 'a -> int +(** Same as [size] in kilobytes. *) + +(** {6 Physical size of an ocaml value with sharing.} *) + +(** This time, all the size of objects are computed with respect + to a larger object containing them all, and we only count + the new blocks not already seen earlier in the left-to-right + visit of the englobing object. *) + +(** Provides the global object in which we'll search shared sizes *) + +val register_shared_size : 'a -> unit + +(** Shared size (in word) of an object with respect to the global object + given by the last [register_shared_size]. *) + +val shared_size_of_obj : 'a -> int + +(** Same, with an object indicated by its occurrence in the global + object. The very same object could have a zero size or not, depending + of the occurrence we're considering in the englobing object. + For speaking of occurrences, we use an [int list] for a path + of field indexes (leftmost = deepest block, rightmost = top block of the + global object). *) + +val shared_size_of_pos : int list -> int + +(** {6 Logical size of an OCaml value.} *) + +val obj_stats : 'a -> int * int * int +(** Return the (logical) value size, the string size, and the maximum depth of + the object. This loops on cyclic structures. *) + +(** {6 Total size of the allocated ocaml heap. } *) + +val heap_size : unit -> int +(** Heap size, in words. *) + +val heap_size_kb : unit -> int +(** Heap size, in kilobytes. *) diff --git a/lib/cSet.ml b/lib/cSet.ml new file mode 100644 index 00000000..d7d5c70b --- /dev/null +++ b/lib/cSet.ml @@ -0,0 +1,67 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module type OrderedType = +sig + type t + val compare : t -> t -> int +end + +module type S = Set.S + +module Make(M : OrderedType)= Set.Make(M) + +module type HashedType = +sig + type t + val hash : t -> int +end + +module Hashcons(M : OrderedType)(H : HashedType with type t = M.t) = +struct + module Set = Make(M) + + type set = Set.t + type _set = + | SEmpty + | SNode of set * M.t * set * int + + let set_prj : set -> _set = Obj.magic + let set_inj : _set -> set = Obj.magic + + let rec spine s accu = match set_prj s with + | SEmpty -> accu + | SNode (l, v, r, _) -> spine l ((v, r) :: accu) + + let rec umap f s = match set_prj s with + | SEmpty -> set_inj SEmpty + | SNode (l, v, r, h) -> + let l' = umap f l in + let r' = umap f r in + let v' = f v in + set_inj (SNode (l', v', r', h)) + + let rec eqeq s1 s2 = match s1, s2 with + | [], [] -> true + | (v1, r1) :: s1, (v2, r2) :: s2 -> + v1 == v2 && eqeq (spine r1 s1) (spine r2 s2) + | _ -> false + + module Hashed = + struct + open Hashset.Combine + type t = set + type u = M.t -> M.t + let equal s1 s2 = s1 == s2 || eqeq (spine s1 []) (spine s2 []) + let hash s = Set.fold (fun v accu -> combine (H.hash v) accu) s 0 + let hashcons = umap + end + + include Hashcons.Make(Hashed) + +end diff --git a/lib/cSet.mli b/lib/cSet.mli new file mode 100644 index 00000000..e5505410 --- /dev/null +++ b/lib/cSet.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module type OrderedType = +sig + type t + val compare : t -> t -> int +end + +module type S = Set.S + +module Make(M : OrderedType) : S + with type elt = M.t + and type t = Set.Make(M).t + +module type HashedType = +sig + type t + val hash : t -> int +end + +module Hashcons (M : OrderedType) (H : HashedType with type t = M.t) : Hashcons.S with + type t = Set.Make(M).t + and type u = M.t -> M.t +(** Create hash-consing for sets. The hashing function provided must be + compatible with the comparison function. *) diff --git a/lib/cSig.mli b/lib/cSig.mli new file mode 100644 index 00000000..2a8bda29 --- /dev/null +++ b/lib/cSig.mli @@ -0,0 +1,47 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Missing pervasive types from OCaml stdlib *) + +type ('a, 'b) union = Inl of 'a | Inr of 'b +(** Union type *) + +type 'a until = Stop of 'a | Cont of 'a +(** Used for browsable-until structures. *) + +module type SetS = +sig + type elt + type t + val empty: t + val is_empty: t -> bool + val mem: elt -> t -> bool + val add: elt -> t -> t + val singleton: elt -> t + val remove: elt -> t -> t + val union: t -> t -> t + val inter: t -> t -> t + val diff: t -> t -> t + val compare: t -> t -> int + val equal: t -> t -> bool + val subset: t -> t -> bool + val iter: (elt -> unit) -> t -> unit + val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all: (elt -> bool) -> t -> bool + val exists: (elt -> bool) -> t -> bool + val filter: (elt -> bool) -> t -> t + val partition: (elt -> bool) -> t -> t * t + val cardinal: t -> int + val elements: t -> elt list + val min_elt: t -> elt + val max_elt: t -> elt + val choose: t -> elt + val split: elt -> t -> t * bool * t +end +(** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml + documentation for more information. *) diff --git a/lib/cStack.ml b/lib/cStack.ml new file mode 100644 index 00000000..4acb2930 --- /dev/null +++ b/lib/cStack.ml @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +exception Empty = Stack.Empty + +type 'a t = { + mutable stack : 'a list; +} + +let create () = { stack = [] } + +let push x s = s.stack <- x :: s.stack + +let pop = function + | { stack = [] } -> raise Stack.Empty + | { stack = x::xs } as s -> s.stack <- xs; x + +let top = function + | { stack = [] } -> raise Stack.Empty + | { stack = x::_ } -> x + +let to_list { stack = s } = s + +let find f s = List.find f (to_list s) + +let find_map f s = CList.find_map f s.stack + +let fold_until f accu s = CList.fold_left_until f accu s.stack + +let is_empty { stack = s } = s = [] + +let iter f { stack = s } = List.iter f s + +let clear s = s.stack <- [] + +let length { stack = s } = List.length s + diff --git a/lib/cStack.mli b/lib/cStack.mli new file mode 100644 index 00000000..8dde1d1a --- /dev/null +++ b/lib/cStack.mli @@ -0,0 +1,56 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Extended interface for OCaml stacks. *) + +type 'a t + +exception Empty +(** Alias for Stack.Empty. *) + +val create : unit -> 'a t +(** Create an empty stack. *) + +val push : 'a -> 'a t -> unit +(** Add an element to a stack. *) + +val find : ('a -> bool) -> 'a t -> 'a +(** Find the first element satisfying the predicate. + @raise Not_found it there is none. *) + +val is_empty : 'a t -> bool +(** Whether a stack is empty. *) + +val iter : ('a -> unit) -> 'a t -> unit +(** Iterate a function over elements, from the last added one. *) + +val clear : 'a t -> unit +(** Empty a stack. *) + +val length : 'a t -> int +(** Length of a stack. *) + +val pop : 'a t -> 'a +(** Remove and returns the first element of the stack. + @raise Empty if empty. *) + +val top : 'a t -> 'a +(** Remove the first element of the stack without modifying it. + @raise Empty if empty. *) + +val to_list : 'a t -> 'a list +(** Convert to a list. *) + +val find_map : ('a -> 'b option) -> 'a t -> 'b +(** Find the first element that returns [Some _]. + @raise Not_found it there is none. *) + +val fold_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a t -> 'c +(** Like CList.fold_left_until. + The stack is traversed from the top and is not altered. *) + diff --git a/lib/cString.ml b/lib/cString.ml new file mode 100644 index 00000000..250b7cee --- /dev/null +++ b/lib/cString.ml @@ -0,0 +1,174 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module type S = module type of String + +module type ExtS = +sig + include S + external equal : string -> string -> bool = "caml_string_equal" "noalloc" + val hash : string -> int + val is_empty : string -> bool + val explode : string -> string list + val implode : string list -> string + val strip : string -> string + val map : (char -> char) -> string -> string + val drop_simple_quotes : string -> string + val string_index_from : string -> int -> string -> int + val string_contains : where:string -> what:string -> bool + val plural : int -> string -> string + val conjugate_verb_to_be : int -> string + val ordinal : int -> string + val split : char -> string -> string list + val is_sub : string -> string -> int -> bool + module Set : Set.S with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + module List : CList.MonoS with type elt = t + val hcons : string -> string +end + +include String + +external equal : string -> string -> bool = "caml_string_equal" "noalloc" + +let rec hash len s i accu = + if i = len then accu + else + let c = Char.code (String.unsafe_get s i) in + hash len s (succ i) (accu * 19 + c) + +let hash s = + let len = String.length s in + hash len s 0 0 + +let explode s = + let rec explode_rec n = + if n >= String.length s then + [] + else + String.make 1 (String.get s n) :: explode_rec (succ n) + in + explode_rec 0 + +let implode sl = String.concat "" sl + +let is_blank = function + | ' ' | '\r' | '\t' | '\n' -> true + | _ -> false + +let is_empty s = String.length s = 0 + +let strip s = + let n = String.length s in + let rec lstrip_rec i = + if i < n && is_blank s.[i] then + lstrip_rec (i+1) + else i + in + let rec rstrip_rec i = + if i >= 0 && is_blank s.[i] then + rstrip_rec (i-1) + else i + in + let a = lstrip_rec 0 and b = rstrip_rec (n-1) in + String.sub s a (b-a+1) + +let map f s = + let l = String.length s in + let r = String.create l in + for i = 0 to (l - 1) do r.[i] <- f (s.[i]) done; + r + +let drop_simple_quotes s = + let n = String.length s in + if n > 2 && s.[0] = '\'' && s.[n-1] = '\'' then String.sub s 1 (n-2) else s + +(* substring searching... *) + +(* gdzie = where, co = what *) +(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *) +let rec raw_is_sub gdzie gl gi co cl ci = + (ci>=cl) || + ((String.unsafe_get gdzie gi = String.unsafe_get co ci) && + (raw_is_sub gdzie gl (gi+1) co cl (ci+1))) + +let rec raw_str_index i gdzie l c co cl = + (* First adapt to ocaml 3.11 new semantics of index_from *) + if (i+cl > l) then raise Not_found; + (* Then proceed as in ocaml < 3.11 *) + let i' = String.index_from gdzie i c in + if (i'+cl <= l) && (raw_is_sub gdzie l i' co cl 0) then i' else + raw_str_index (i'+1) gdzie l c co cl + +let string_index_from gdzie i co = + if co="" then i else + raw_str_index i gdzie (String.length gdzie) + (String.unsafe_get co 0) co (String.length co) + +let string_contains ~where ~what = + try + let _ = string_index_from where 0 what in true + with + Not_found -> false + +let is_sub p s off = + let lp = String.length p in + let ls = String.length s in + if ls < off + lp then false + else + let rec aux i = + if lp <= i then true + else + let cp = String.unsafe_get p i in + let cs = String.unsafe_get s (off + i) in + if cp = cs then aux (succ i) else false + in + aux 0 + +let plural n s = if n<>1 then s^"s" else s + +let conjugate_verb_to_be n = if n<>1 then "are" else "is" + +let ordinal n = + let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in + string_of_int n ^ s + +(* string parsing *) + +let split c s = + let len = String.length s in + let rec split n = + try + let pos = String.index_from s n c in + let dir = String.sub s n (pos-n) in + dir :: split (succ pos) + with + | Not_found -> [String.sub s n (len-n)] + in + if Int.equal len 0 then [] else split 0 + +module Self = +struct + type t = string + let compare = compare +end + +module Set = Set.Make(Self) +module Map = CMap.Make(Self) + +module List = struct + type elt = string + let mem id l = List.exists (fun s -> equal id s) l + let assoc id l = CList.assoc_f equal id l + let remove_assoc id l = CList.remove_assoc_f equal id l + let mem_assoc id l = List.exists (fun (a,_) -> equal id a) l + let mem_assoc_sym id l = List.exists (fun (_,b) -> equal id b) l + let equal l l' = CList.equal equal l l' +end + +let hcons = Hashcons.simple_hcons Hashcons.Hstring.generate Hashcons.Hstring.hcons () diff --git a/lib/cString.mli b/lib/cString.mli new file mode 100644 index 00000000..4fa9e1e9 --- /dev/null +++ b/lib/cString.mli @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Module type [S] is the one from OCaml Stdlib. *) +module type S = module type of String + +module type ExtS = +sig + include S + (** We include the standard library *) + + external equal : string -> string -> bool = "caml_string_equal" "noalloc" + (** Equality on strings *) + + val hash : string -> int + (** Hashing on strings. Should be compatible with generic one. *) + + val is_empty : string -> bool + (** Test whether a string is empty. *) + + val explode : string -> string list + (** [explode "x1...xn"] returns [["x1"; ...; "xn"]] *) + + val implode : string list -> string + (** [implode [s1; ...; sn]] returns [s1 ^ ... ^ sn] *) + + val strip : string -> string + (** Remove the surrounding blank characters from a string *) + + val map : (char -> char) -> string -> string + (** Apply a function on a string character-wise. *) + + val drop_simple_quotes : string -> string + (** Remove the eventual first surrounding simple quotes of a string. *) + + val string_index_from : string -> int -> string -> int + (** As [index_from], but takes a string instead of a char as pattern argument *) + + val string_contains : where:string -> what:string -> bool + (** As [contains], but takes a string instead of a char as pattern argument *) + + val plural : int -> string -> string + (** [plural n s] adds a optional 's' to the [s] when [2 <= n]. *) + + val conjugate_verb_to_be : int -> string + (** [conjugate_verb_to_be] returns "is" when [n=1] and "are" otherwise *) + + val ordinal : int -> string + (** Generate the ordinal number in English. *) + + val split : char -> string -> string list + (** [split c s] splits [s] into sequences separated by [c], excluded. *) + + val is_sub : string -> string -> int -> bool + (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *) + + (** {6 Generic operations} **) + + module Set : Set.S with type elt = t + (** Finite sets on [string] *) + + module Map : CMap.ExtS with type key = t and module Set := Set + (** Finite maps on [string] *) + + module List : CList.MonoS with type elt = t + (** Association lists with [string] as keys *) + + val hcons : string -> string + (** Hashconsing on [string] *) + +end + +include ExtS diff --git a/lib/cThread.ml b/lib/cThread.ml new file mode 100644 index 00000000..55bb6fd6 --- /dev/null +++ b/lib/cThread.ml @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type thread_ic = in_channel + +let prepare_in_channel_for_thread_friendly_io ic = + Unix.set_nonblock (Unix.descr_of_in_channel ic); ic + +let safe_wait_timed_read fd time = + try Thread.wait_timed_read fd time + with Unix.Unix_error (Unix.EINTR, _, _) -> + (** On Unix, the above function may raise this exception when it is + interrupted by a signal. (It uses Unix.select internally.) *) + false + +let thread_friendly_read_fd fd s ~off ~len = + let rec loop () = + try Unix.read fd s off len + with Unix.Unix_error((Unix.EWOULDBLOCK|Unix.EAGAIN|Unix.EINTR),_,_) -> + while not (safe_wait_timed_read fd 1.0) do Thread.yield () done; + loop () + in + loop () + +let thread_friendly_read ic s ~off ~len = + try + let fd = Unix.descr_of_in_channel ic in + thread_friendly_read_fd fd s ~off ~len + with Unix.Unix_error _ -> 0 + +let really_read_fd fd s off len = + let i = ref 0 in + while !i < len do + let off = off + !i in + let len = len - !i in + let r = thread_friendly_read_fd fd s ~off ~len in + if r = 0 then raise End_of_file; + i := !i + r + done + +let thread_friendly_really_read ic s ~off ~len = + try + let fd = Unix.descr_of_in_channel ic in + really_read_fd fd s off len + with Unix.Unix_error _ -> raise End_of_file + +let thread_friendly_really_read_line ic = + try + let fd = Unix.descr_of_in_channel ic in + let b = Buffer.create 1024 in + let s = String.make 1 '\000' in + while s <> "\n" do + let n = thread_friendly_read_fd fd s ~off:0 ~len:1 in + if n = 0 then raise End_of_file; + if s <> "\n" then Buffer.add_string b s; + done; + Buffer.contents b + with Unix.Unix_error _ -> raise End_of_file + +let thread_friendly_input_value ic = + try + let fd = Unix.descr_of_in_channel ic in + let header = String.create Marshal.header_size in + really_read_fd fd header 0 Marshal.header_size; + let body_size = Marshal.data_size header 0 in + let msg = String.create (body_size + Marshal.header_size) in + String.blit header 0 msg 0 Marshal.header_size; + really_read_fd fd msg Marshal.header_size body_size; + Marshal.from_string msg 0 + with Unix.Unix_error _ -> raise End_of_file + diff --git a/lib/cThread.mli b/lib/cThread.mli new file mode 100644 index 00000000..8b110f3f --- /dev/null +++ b/lib/cThread.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* As of OCaml 4.01.0 input_value and input do not quite work well + * with threads. The symptom is the following. Two threads, each + * of them blocked on a read (on different channels). One is not + * woken up even if data is available. When the other one gets data + * then the stuck one is eventually unblocked too. Unix.select with + * an unbounded wait has the same problem. *) + +(* Use only the following functions on the channel *) +type thread_ic +val prepare_in_channel_for_thread_friendly_io : in_channel -> thread_ic + +val thread_friendly_input_value : thread_ic -> 'a +val thread_friendly_read : + thread_ic -> string -> off:int -> len:int -> int +val thread_friendly_really_read : + thread_ic -> string -> off:int -> len:int -> unit +val thread_friendly_really_read_line : thread_ic -> string + diff --git a/lib/cUnix.ml b/lib/cUnix.ml new file mode 100644 index 00000000..4a1fc762 --- /dev/null +++ b/lib/cUnix.ml @@ -0,0 +1,139 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Files and load path. *) + +type physical_path = string +type load_path = physical_path list + +let physical_path_of_string s = s +let string_of_physical_path p = p + +let path_to_list p = + let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in + Str.split sep p + +(* Some static definitions concerning filenames *) + +let dirsep = Filename.dir_sep (* Unix: "/" *) +let dirsep_len = String.length dirsep +let curdir = Filename.concat Filename.current_dir_name "" (* Unix: "./" *) +let curdir_len = String.length curdir + +(* Hints to partially detects if two paths refer to the same directory *) + +(** cut path [p] after all the [/] that come at position [pos]. *) +let rec cut_after_dirsep p pos = + if CString.is_sub dirsep p pos then + cut_after_dirsep p (pos + dirsep_len) + else + String.sub p pos (String.length p - pos) + +(** remove all initial "./" in a path unless the path is exactly "./" *) +let rec remove_path_dot p = + if CString.is_sub curdir p 0 then + if String.length p = curdir_len + then Filename.current_dir_name + else remove_path_dot (cut_after_dirsep p curdir_len) + else + p + +(** If a path [p] starts with the current directory $PWD then + [strip_path p] returns the sub-path relative to $PWD. + Any leading "./" are also removed from the result. *) +let strip_path p = + let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) + if CString.is_sub cwd p 0 then + remove_path_dot (cut_after_dirsep p (String.length cwd)) + else + remove_path_dot p + +let canonical_path_name p = + let current = Sys.getcwd () in + try + Sys.chdir p; + let p' = Sys.getcwd () in + Sys.chdir current; + p' + with Sys_error _ -> + (* We give up to find a canonical name and just simplify it... *) + strip_path p + +let make_suffix name suffix = + if Filename.check_suffix name suffix then name else (name ^ suffix) + +let get_extension f = + let pos = try String.rindex f '.' with Not_found -> String.length f in + String.sub f pos (String.length f - pos) + +let correct_path f dir = + if Filename.is_relative f then Filename.concat dir f else f + +let file_readable_p name = + try Unix.access name [Unix.R_OK];true + with Unix.Unix_error (_, _, _) -> false + +(* As for [Unix.close_process], a [Unix.waipid] that ignores all [EINTR] *) + +let rec waitpid_non_intr pid = + try snd (Unix.waitpid [] pid) + with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid + +(** [run_command com] launches command [com] (via /bin/sh), + and returns the contents of stdout and stderr. If given, [~hook] + is called on each elements read on stdout or stderr. *) + +let run_command ?(hook=(fun _ ->())) c = + let result = Buffer.create 127 in + let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in + let buff = String.make 127 ' ' in + let buffe = String.make 127 ' ' in + let n = ref 0 in + let ne = ref 0 in + while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; + !n+ !ne <> 0 + do + let r = String.sub buff 0 !n in (hook r; Buffer.add_string result r); + let r = String.sub buffe 0 !ne in (hook r; Buffer.add_string result r); + done; + (Unix.close_process_full (cin,cout,cerr), Buffer.contents result) + +(** [sys_command] launches program [prog] with arguments [args]. + It behaves like [Sys.command], except that we rely on + [Unix.create_process], it's hardly more complex and avoids dealing + with shells. In particular, no need to quote arguments + (against whitespace or other funny chars in paths), hence no need + to care about the different quoting conventions of /bin/sh and cmd.exe. *) + +let sys_command prog args = + let argv = Array.of_list (prog::args) in + let pid = Unix.create_process prog argv Unix.stdin Unix.stdout Unix.stderr in + waitpid_non_intr pid + +(* + checks if two file names refer to the same (existing) file by + comparing their device and inode. + It seems that under Windows, inode is always 0, so we cannot + accurately check if + +*) +(* Optimised for partial application (in case many candidates must be + compared to f1). *) +let same_file f1 = + try + let s1 = Unix.stat f1 in + (fun f2 -> + try + let s2 = Unix.stat f2 in + s1.Unix.st_dev = s2.Unix.st_dev && + if Sys.os_type = "Win32" then f1 = f2 + else s1.Unix.st_ino = s2.Unix.st_ino + with + Unix.Unix_error _ -> false) + with + Unix.Unix_error _ -> (fun _ -> false) diff --git a/lib/cUnix.mli b/lib/cUnix.mli new file mode 100644 index 00000000..2d0d202d --- /dev/null +++ b/lib/cUnix.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** {5 System utilities} *) + +type physical_path = string +type load_path = physical_path list + +val physical_path_of_string : string -> physical_path +val string_of_physical_path : physical_path -> string + +val canonical_path_name : string -> string + +(** remove all initial "./" in a path *) +val remove_path_dot : string -> string + +(** If a path [p] starts with the current directory $PWD then + [strip_path p] returns the sub-path relative to $PWD. + Any leading "./" are also removed from the result. *) +val strip_path : string -> string + +(** correct_path f dir = dir/f if f is relative *) +val correct_path : string -> string -> string + +val path_to_list : string -> string list + +(** [make_suffix file suf] catenate [file] with [suf] when + [file] does not already end with [suf]. *) +val make_suffix : string -> string -> string + +(** Return the extension of a file, i.e. its smaller suffix starting + with "." if any, or "" otherwise. *) +val get_extension : string -> string + +val file_readable_p : string -> bool + +(** {6 Executing commands } *) + +(** [run_command com] launches command [com], and returns + the contents of stdout and stderr. If given, [~hook] + is called on each elements read on stdout or stderr. *) + +val run_command : + ?hook:(string->unit) -> string -> Unix.process_status * string + +(** [sys_command] launches program [prog] with arguments [args]. + It behaves like [Sys.command], except that we rely on + [Unix.create_process], it's hardly more complex and avoids dealing + with shells. In particular, no need to quote arguments + (against whitespace or other funny chars in paths), hence no need + to care about the different quoting conventions of /bin/sh and cmd.exe. *) + +val sys_command : string -> string list -> Unix.process_status + +(** A version of [Unix.waitpid] immune to EINTR exceptions *) + +val waitpid_non_intr : int -> Unix.process_status + +(** checks if two file names refer to the same (existing) file *) +val same_file : string -> string -> bool + diff --git a/lib/gmapl.ml b/lib/canary.ml index 987ff9af..23d7bd21 100644 --- a/lib/gmapl.ml +++ b/lib/canary.ml @@ -1,33 +1,26 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util +type t = Obj.t -type ('a,'b) t = ('a,'b list) Gmap.t +let obj = Obj.new_block Obj.closure_tag 0 + (** This is an empty closure block. In the current implementation, it is + sufficient to allow marshalling but forbid equality. Sadly still allows + hash. *) + (** FIXME : use custom blocks somehow. *) -let empty = Gmap.empty -let mem = Gmap.mem -let iter = Gmap.iter -let map = Gmap.map -let fold = Gmap.fold - -let add x y m = - try - let l = Gmap.find x m in - Gmap.add x (y::list_except y l) m - with Not_found -> - Gmap.add x [y] m - -let find x m = - try Gmap.find x m with Not_found -> [] - -let remove x y m = - let l = Gmap.find x m in - Gmap.add x (if List.mem y l then list_subtract l [y] else l) m +module type Obj = sig type t end +module Make(M : Obj) = +struct + type canary = t + type t = (canary * M.t) + let prj (_, x) = x + let inj x = (obj, x) +end diff --git a/lib/gmapl.mli b/lib/canary.mli index 5b81459b..c0ba86a7 100644 --- a/lib/gmapl.mli +++ b/lib/canary.mli @@ -1,21 +1,25 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Maps from ['a] to lists of ['b]. *) +type t +(** Type of canaries. Canaries are used to ensure that an object does not use + generic operations. *) -type ('a,'b) t +val obj : t +(** Canary. In the current implementation, this object is marshallable, + forbids generic comparison but still allows generic hashes. *) -val empty : ('a,'b) t -val mem : 'a -> ('a,'b) t -> bool -val iter : ('a -> 'b list -> unit) -> ('a,'b) t -> unit -val map : ('b list -> 'c list) -> ('a,'b) t -> ('a,'c) t -val fold : ('a -> 'b list -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c +module type Obj = sig type t end -val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t -val find : 'a -> ('a,'b) t -> 'b list -val remove : 'a -> 'b -> ('a,'b) t -> ('a,'b) t +module Make(M : Obj) : +sig + type t + val prj : t -> M.t + val inj : M.t -> t +end +(** Adds a canary to any type. *) diff --git a/lib/clib.mllib b/lib/clib.mllib new file mode 100644 index 00000000..2da81c95 --- /dev/null +++ b/lib/clib.mllib @@ -0,0 +1,39 @@ +Coq_config + +Terminal +Canary +Hook +Hashset +Hashcons +CSet +CMap +Int +HMap +Option +Store +Exninfo +Backtrace +IStream +Pp_control +Flags +Control +Loc +Serialize +Deque +CObj +CList +CString +CArray +CStack +Util +Stateid +Feedback +Pp +Xml_lexer +Xml_parser +Xml_printer +Richpp +CUnix +Envars +Aux_file +Monad diff --git a/lib/compat.ml4 b/lib/compat.ml4 deleted file mode 100644 index 73cbc6d6..00000000 --- a/lib/compat.ml4 +++ /dev/null @@ -1,242 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** Compatibility file depending on ocaml/camlp4 version *) - -(** Locations *) - -IFDEF CAMLP5 THEN - -module Loc = struct - include Ploc - exception Exc_located = Exc - let ghost = dummy - let merge = encl -end - -let make_loc = Loc.make_unlined -let unloc loc = (Loc.first_pos loc, Loc.last_pos loc) - -ELSE - -module Loc = Camlp4.PreCast.Loc - -let make_loc (start,stop) = - Loc.of_tuple ("", 0, 0, start, 0, 0, stop, false) -let unloc loc = (Loc.start_off loc, Loc.stop_off loc) - -END - -(** Misc module emulation *) - -IFDEF CAMLP5 THEN - -module PcamlSig = struct end - -ELSE - -module PcamlSig = Camlp4.Sig -module Ast = Camlp4.PreCast.Ast -module Pcaml = Camlp4.PreCast.Syntax -module MLast = Ast -module Token = struct exception Error of string end - -END - - -(** Grammar auxiliary types *) - -IFDEF CAMLP5 THEN -type gram_assoc = Gramext.g_assoc = NonA | RightA | LeftA -type gram_position = Gramext.position = - | First - | Last - | Before of string - | After of string - | Like of string (** dont use it, not in camlp4 *) - | Level of string -ELSE -type gram_assoc = PcamlSig.Grammar.assoc = NonA | RightA | LeftA -type gram_position = PcamlSig.Grammar.position = - | First - | Last - | Before of string - | After of string - | Level of string -END - - -(** Signature of Lexer *) - -IFDEF CAMLP5 THEN - -module type LexerSig = sig - include Grammar.GLexerType with type te = Tok.t - module Error : sig - type t - exception E of t - val to_string : t -> string - end -end - -ELSE - -module type LexerSig = - Camlp4.Sig.Lexer with module Loc = Loc and type Token.t = Tok.t - -END - -(** Signature and implementation of grammars *) - -IFDEF CAMLP5 THEN - -module type GrammarSig = sig - include Grammar.S with type te = Tok.t - type 'a entry = 'a Entry.e - type internal_entry = Tok.t Gramext.g_entry - type symbol = Tok.t Gramext.g_symbol - type action = Gramext.g_action - type production_rule = symbol list * action - type single_extend_statment = - string option * gram_assoc option * production_rule list - type extend_statment = - gram_position option * single_extend_statment list - val action : 'a -> action - val entry_create : string -> 'a entry - val entry_parse : 'a entry -> parsable -> 'a - val entry_print : 'a entry -> unit - val srules' : production_rule list -> symbol - val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a -end - -module GrammarMake (L:LexerSig) : GrammarSig = struct - include Grammar.GMake (L) - type 'a entry = 'a Entry.e - type internal_entry = Tok.t Gramext.g_entry - type symbol = Tok.t Gramext.g_symbol - type action = Gramext.g_action - type production_rule = symbol list * action - type single_extend_statment = - string option * gram_assoc option * production_rule list - type extend_statment = - gram_position option * single_extend_statment list - let action = Gramext.action - let entry_create = Entry.create - let entry_parse = Entry.parse -IFDEF CAMLP5_6_02_1 THEN - let entry_print x = Entry.print !Pp_control.std_ft x -ELSE - let entry_print = Entry.print -END - let srules' = Gramext.srules - let parse_tokens_after_filter = Entry.parse_token -end - -ELSE - -module type GrammarSig = sig - include Camlp4.Sig.Grammar.Static - with module Loc = Loc and type Token.t = Tok.t - type 'a entry = 'a Entry.t - type action = Action.t - type parsable - val parsable : char Stream.t -> parsable - val action : 'a -> action - val entry_create : string -> 'a entry - val entry_parse : 'a entry -> parsable -> 'a - val entry_print : 'a entry -> unit - val srules' : production_rule list -> symbol -end - -module GrammarMake (L:LexerSig) : GrammarSig = struct - include Camlp4.Struct.Grammar.Static.Make (L) - type 'a entry = 'a Entry.t - type action = Action.t - type parsable = char Stream.t - let parsable s = s - let action = Action.mk - let entry_create = Entry.mk - let entry_parse e s = parse e (*FIXME*)Loc.ghost s - let entry_print x = Entry.print !Pp_control.std_ft x - let srules' = srules (entry_create "dummy") -end - -END - - -(** Misc functional adjustments *) - -(** - The lexer produces streams made of pairs in camlp4 *) - -let get_tok = IFDEF CAMLP5 THEN fun x -> x ELSE fst END - -(** - Gram.extend is more currified in camlp5 than in camlp4 *) - -IFDEF CAMLP5 THEN -let maybe_curry f x y = f (x,y) -let maybe_uncurry f (x,y) = f x y -ELSE -let maybe_curry f = f -let maybe_uncurry f = f -END - -(** Compatibility with camlp5 strict mode *) -IFDEF CAMLP5 THEN - IFDEF STRICT THEN - let vala x = Ploc.VaVal x - ELSE - let vala x = x - END -ELSE - let vala x = x -END - -(** Fix a quotation difference in [str_item] *) - -let declare_str_items loc l = -IFDEF CAMLP5 THEN - MLast.StDcl (loc, vala l) (* correspond to <:str_item< declare $list:l'$ end >> *) -ELSE - Ast.stSem_of_list l -END - -(** Quotation difference for match clauses *) - -let default_patt loc = - (<:patt< _ >>, vala None, <:expr< failwith "Extension: cannot occur" >>) - -IFDEF CAMLP5 THEN - -let make_fun loc cl = - let l = cl @ [default_patt loc] in - MLast.ExFun (loc, vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *) - -ELSE - -let make_fun loc cl = - let mk_when = function - | Some w -> w - | None -> Ast.ExNil loc - in - let mk_clause (patt,optwhen,expr) = - (* correspond to <:match_case< ... when ... -> ... >> *) - Ast.McArr (loc, patt, mk_when optwhen, expr) in - let init = mk_clause (default_patt loc) in - let add_clause x acc = Ast.McOr (loc, mk_clause x, acc) in - let l = List.fold_right add_clause cl init in - Ast.ExFun (loc,l) (* correspond to <:expr< fun [ $l$ ] >> *) - -END - -(** Explicit antiquotation $anti:... $ *) - -IFDEF CAMLP5 THEN -let expl_anti loc e = <:expr< $anti:e$ >> -ELSE -let expl_anti _loc e = e (* FIXME: understand someday if we can do better *) -END diff --git a/lib/control.ml b/lib/control.ml new file mode 100644 index 00000000..673a75a2 --- /dev/null +++ b/lib/control.ml @@ -0,0 +1,91 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*s interruption *) + +let interrupt = ref false + +let steps = ref 0 + +let are_we_threading = lazy ( + match !Flags.async_proofs_mode with + | Flags.APon -> true + | _ -> false) + +let check_for_interrupt () = + if !interrupt then begin interrupt := false; raise Sys.Break end; + incr steps; + if !steps = 1000 && Lazy.force are_we_threading then begin + Thread.delay 0.001; + steps := 0; + end + +(** This function does not work on windows, sigh... *) +let unix_timeout n f e = + let timeout_handler _ = raise e in + let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in + let _ = Unix.alarm n in + let restore_timeout () = + let _ = Unix.alarm 0 in + Sys.set_signal Sys.sigalrm psh + in + try + let res = f () in + restore_timeout (); + res + with e -> + let e = Backtrace.add_backtrace e in + restore_timeout (); + Exninfo.iraise e + +let windows_timeout n f e = + let killed = ref false in + let exited = ref false in + let thread init = + while not !killed do + let cur = Unix.time () in + if float_of_int n <= cur -. init then begin + interrupt := true; + exited := true; + Thread.exit () + end; + Thread.delay 0.5 + done + in + let init = Unix.time () in + let _id = Thread.create thread init in + try + let res = f () in + let () = killed := true in + let cur = Unix.time () in + (** The thread did not interrupt, but the computation took longer than + expected. *) + let () = if float_of_int n <= cur -. init then begin + exited := true; + raise Sys.Break + end in + res + with + | Sys.Break -> + (** Just in case, it could be a regular Ctrl+C *) + if not !exited then begin killed := true; raise Sys.Break end + else raise e + | e -> + let () = killed := true in + let e = Backtrace.add_backtrace e in + Exninfo.iraise e + +type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a } + +let timeout_fun = match Sys.os_type with +| "Unix" | "Cygwin" -> ref { timeout = unix_timeout } +| _ -> ref { timeout = windows_timeout } + +let set_timeout f = timeout_fun := f + +let timeout n f e = !timeout_fun.timeout n f e diff --git a/lib/control.mli b/lib/control.mli new file mode 100644 index 00000000..2a496bca --- /dev/null +++ b/lib/control.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Global control of Coq. *) + +val interrupt : bool ref +(** Coq interruption: set the following boolean reference to interrupt Coq + (it eventually raises [Break], simulating a Ctrl-C) *) + +val check_for_interrupt : unit -> unit +(** Use this function as a potential yield function. If {!interrupt} has been + set, il will raise [Sys.Break]. *) + +val timeout : int -> (unit -> 'a) -> exn -> 'a +(** [timeout n f e] tries to compute [f], and if it fails to do so before [n] + seconds, it raises [e] instead. *) + +type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a } + +val set_timeout : timeout -> unit +(** Set a particular timeout function. *) diff --git a/lib/deque.ml b/lib/deque.ml new file mode 100644 index 00000000..c04d5993 --- /dev/null +++ b/lib/deque.ml @@ -0,0 +1,97 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +exception Empty + +type 'a t = { + face : 'a list; + rear : 'a list; + lenf : int; + lenr : int; +} + +let rec split i accu l = match l with +| [] -> + if Int.equal i 0 then (accu, []) else invalid_arg "split" +| t :: q -> + if Int.equal i 0 then (accu, l) + else split (pred i) (t :: accu) q + +let balance q = + let avg = (q.lenf + q.lenr) / 2 in + let dif = q.lenf + q.lenr - avg in + if q.lenf > succ (2 * q.lenr) then + let (ff, fr) = split avg [] q.face in + { face = List.rev ff ; rear = q.rear @ List.rev fr; lenf = avg; lenr = dif } + else if q.lenr > succ (2 * q.lenf) then + let (rf, rr) = split avg [] q.rear in + { face = q.face @ List.rev rr ; rear = List.rev rf; lenf = dif; lenr = avg } + else q + +let empty = { + face = []; + rear = []; + lenf = 0; + lenr = 0; +} + +let lcons x q = + balance { q with lenf = succ q.lenf; face = x :: q.face } + +let lhd q = match q.face with +| [] -> + begin match q.rear with + | [] -> raise Empty + | t :: _ -> t + end +| t :: _ -> t + +let ltl q = match q.face with +| [] -> + begin match q.rear with + | [] -> raise Empty + | t :: _ -> empty + end +| t :: r -> balance { q with lenf = pred q.lenf; face = r } + +let rcons x q = + balance { q with lenr = succ q.lenr; rear = x :: q.rear } + +let rhd q = match q.rear with +| [] -> + begin match q.face with + | [] -> raise Empty + | t :: r -> t + end +| t :: _ -> t + +let rtl q = match q.rear with +| [] -> + begin match q.face with + | [] -> raise Empty + | t :: r -> empty + end +| t :: r -> + balance { q with lenr = pred q.lenr; rear = r } + +let rev q = { + face = q.rear; + rear = q.face; + lenf = q.lenr; + lenr = q.lenf; +} + +let length q = q.lenf + q.lenr + +let is_empty q = Int.equal (length q) 0 + +let filter f q = + let fold (accu, len) x = if f x then (x :: accu, succ len) else (accu, len) in + let (rf, lenf) = List.fold_left fold ([], 0) q.face in + let (rr, lenr) = List.fold_left fold ([], 0) q.rear in + balance { face = List.rev rf; rear = List.rev rr; lenf = lenf; lenr = lenr } diff --git a/lib/deque.mli b/lib/deque.mli new file mode 100644 index 00000000..fd644e3c --- /dev/null +++ b/lib/deque.mli @@ -0,0 +1,58 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Purely functional, double-ended queues *) + +(** This module implements the banker's deque, from Okasaki. Most operations are + amortized O(1). *) + +type +'a t + +exception Empty + +(** {5 Constructor} *) + +val empty : 'a t + +(** The empty deque. *) + +(** {5 Left-side operations} *) + +val lcons : 'a -> 'a t -> 'a t +(** Pushes an element on the left side of the deque. *) + +val lhd : 'a t -> 'a +(** Returns the leftmost element in the deque. Raises [Empty] when empty. *) + +val ltl : 'a t -> 'a t +(** Returns the left-tail of the deque. Raises [Empty] when empty. *) + +(** {5 Right-side operations} *) + +val rcons : 'a -> 'a t -> 'a t +(** Same as [lcons] but on the right side. *) + +val rhd : 'a t -> 'a +(** Same as [lhd] but on the right side. *) + +val rtl : 'a t -> 'a t +(** Same as [ltl] but on the right side. *) + +(** {5 Operations} *) + +val rev : 'a t -> 'a t +(** Reverse deque. *) + +val length : 'a t -> int +(** Length of a deque. *) + +val is_empty : 'a t -> bool +(** Emptyness of a deque. *) + +val filter : ('a -> bool) -> 'a t -> 'a t +(** Filters the deque *) diff --git a/lib/dnet.ml b/lib/dnet.ml deleted file mode 100644 index 7f9bd949..00000000 --- a/lib/dnet.ml +++ /dev/null @@ -1,293 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Generic dnet implementation over non-recursive types *) - -module type Datatype = -sig - type 'a t - val map : ('a -> 'b) -> 'a t -> 'b t - val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t - val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a - val compare : unit t -> unit t -> int - val terminal : 'a t -> bool - val choose : ('a -> 'b) -> 'a t -> 'b -end - -module type S = -sig - type t - type ident - type meta - type 'a structure - module Idset : Set.S with type elt=ident - type 'a pattern = - | Term of 'a - | Meta of meta - type term_pattern = ('a structure) pattern as 'a - val empty : t - val add : t -> term_pattern -> ident -> t - val find_all : t -> Idset.t - val fold_pattern : - ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a - val find_match : term_pattern -> t -> Idset.t - val inter : t -> t -> t - val union : t -> t -> t - val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t -end - -module Make = - functor (T:Datatype) -> - functor (Ident:Set.OrderedType) -> - functor (Meta:Set.OrderedType) -> -struct - - type ident = Ident.t - type meta = Meta.t - - type 'a pattern = - | Term of 'a - | Meta of meta - - type 'a structure = 'a T.t - - module Idset = Set.Make(Ident) - module Mmap = Map.Make(Meta) - module Tmap = Map.Make(struct type t = unit structure - let compare = T.compare end) - - type term_pattern = term_pattern structure pattern - type idset = Idset.t - - - - (* we store identifiers at the leaf of the dnet *) - type node = - | Node of t structure - | Terminal of t structure * idset - - (* at each node, we have a bunch of nodes (actually a map between - the bare node and a subnet) and a bunch of metavariables *) - and t = Nodes of node Tmap.t * idset Mmap.t - - let empty : t = Nodes (Tmap.empty, Mmap.empty) - - (* the head of a data is of type unit structure *) - let head w = T.map (fun c -> ()) w - - (* given a node of the net and a word, returns the subnet with the - same head as the word (with the rest of the nodes) *) - let split l (w:'a structure) : node * node Tmap.t = - let elt : node = Tmap.find (head w) l in - (elt, Tmap.remove (head w) l) - - let select l w = Tmap.find (head w) l - - let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t = - match w with Term w -> - ( try - let (n,tl) = split t w in - let new_node = match n with - | Terminal (e,is) -> Terminal (e,Idset.add id is) - | Node e -> Node (T.map2 (fun t p -> add t p id) e w) in - Nodes ((Tmap.add (head w) new_node tl), m) - with Not_found -> - let new_content = T.map (fun p -> add empty p id) w in - let new_node = - if T.terminal w then - Terminal (new_content, Idset.singleton id) - else Node new_content in - Nodes ((Tmap.add (head w) new_node t), m) ) - | Meta i -> - let m = - try Mmap.add i (Idset.add id (Mmap.find i m)) m - with Not_found -> Mmap.add i (Idset.singleton id) m in - Nodes (t, m) - - let add t w id = add t w id - - let rec find_all (Nodes (t,m)) : idset = - Idset.union - (Mmap.fold (fun _ -> Idset.union) m Idset.empty) - (Tmap.fold - ( fun _ n acc -> - let s2 = match n with - | Terminal (_,is) -> is - | Node e -> T.choose find_all e in - Idset.union acc s2 - ) t Idset.empty) - -(* (\* optimization hack: Not_found is catched in fold_pattern *\) *) -(* let fast_inter s1 s2 = *) -(* if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *) -(* else Idset.inter s1 s2 *) - -(* let option_any2 f s1 s2 = match s1,s2 with *) -(* | Some s1, Some s2 -> f s1 s2 *) -(* | (Some s, _ | _, Some s) -> s *) -(* | _ -> raise Not_found *) - -(* let fold_pattern ?(complete=true) f acc pat dn = *) -(* let deferred = ref [] in *) -(* let leafs,metas = ref None, ref None in *) -(* let leaf s = leafs := match !leafs with *) -(* | None -> Some s *) -(* | Some s' -> Some (fast_inter s s') in *) -(* let meta s = metas := match !metas with *) -(* | None -> Some s *) -(* | Some s' -> Some (Idset.union s s') in *) -(* let defer c = deferred := c::!deferred in *) -(* let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = *) -(* Mmap.iter (fun _ -> meta) m; (\* TODO: gérer patterns nonlin ici *\) *) -(* match p with *) -(* | Meta m -> defer (m,dn) *) -(* | Term w -> *) -(* try match select t w with *) -(* | Terminal (_,is) -> leaf is *) -(* | Node e -> *) -(* if complete then T.fold2 (fun _ -> fp_rec) () w e else *) -(* if T.fold2 *) -(* (fun b p dn -> match p with *) -(* | Term _ -> fp_rec p dn; false *) -(* | Meta _ -> b *) -(* ) true w e *) -(* then T.choose (T.choose fp_rec w) e *) -(* with Not_found -> *) -(* if Mmap.is_empty m then raise Not_found else () *) -(* in try *) -(* fp_rec pat dn; *) -(* (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), *) -(* List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred *) -(* with Not_found -> None,acc *) - - (* Sets with a neutral element for inter *) - module OSet (S:Set.S) = struct - type t = S.t option - let union s1 s2 = match s1,s2 with - | (None, _ | _, None) -> None - | Some a, Some b -> Some (S.union a b) - let inter s1 s2 = match s1,s2 with - | (None, a | a, None) -> a - | Some a, Some b -> Some (S.inter a b) - let is_empty = function - | None -> false - | Some s -> S.is_empty s - (* optimization hack: Not_found is catched in fold_pattern *) - let fast_inter s1 s2 = - if is_empty s1 || is_empty s2 then raise Not_found - else let r = inter s1 s2 in - if is_empty r then raise Not_found else r - let full = None - let empty = Some S.empty - end - - module OIdset = OSet(Idset) - - let fold_pattern ?(complete=true) f acc pat dn = - let deferred = ref [] in - let defer c = deferred := c::!deferred in - - let rec fp_rec metas p (Nodes(t,m) as dn:t) = - (* TODO gérer les dnets non-linéaires *) - let metas = Mmap.fold (fun _ -> Idset.union) m metas in - match p with - | Meta m -> defer (metas,m,dn); OIdset.full - | Term w -> - let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in - try match select t w with - | Terminal (_,is) -> Some (Idset.union curm is) - | Node e -> - let ids = if complete then T.fold2 - (fun acc w e -> - OIdset.fast_inter acc (fp_rec metas w e) - ) OIdset.full w e - else - let (all_metas, res) = T.fold2 - (fun (b,acc) w e -> match w with - | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e) - | Meta _ -> b, acc - ) (true,OIdset.full) w e in - if all_metas then T.choose (T.choose (fp_rec metas) w) e - else res in - OIdset.union ids (Some curm) - with Not_found -> - if Idset.is_empty metas then raise Not_found else Some curm in - let cand = - try fp_rec Idset.empty pat dn - with Not_found -> OIdset.empty in - let res = List.fold_left f acc !deferred in - cand, res - - (* intersection of two dnets. keep only the common pairs *) - let rec inter (t1:t) (t2:t) : t = - let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = - Nodes - (Tmap.fold - ( fun k e acc -> - try Tmap.add k (f e (Tmap.find k t2)) acc - with Not_found -> acc - ) t1 Tmap.empty, - Mmap.fold - ( fun m s acc -> - try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc - with Not_found -> acc - ) m1 Mmap.empty - ) in - inter_map - (fun n1 n2 -> match n1,n2 with - | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2) - | Node e1, Node e2 -> Node (T.map2 inter e1 e2) - | _ -> assert false - ) t1 t2 - - let rec union (t1:t) (t2:t) : t = - let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = - Nodes - (Tmap.fold - ( fun k e acc -> - try Tmap.add k (f e (Tmap.find k acc)) acc - with Not_found -> Tmap.add k e acc - ) t1 t2, - Mmap.fold - ( fun m s acc -> - try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc - with Not_found -> Mmap.add m s acc - ) m1 m2 - ) in - union_map - (fun n1 n2 -> match n1,n2 with - | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2) - | Node e1, Node e2 -> Node (T.map2 union e1 e2) - | _ -> assert false - ) t1 t2 - - let find_match (p:term_pattern) (t:t) : idset = - let metas = ref Mmap.empty in - let (mset,lset) = fold_pattern ~complete:false - (fun acc (mset,m,t) -> - let all = OIdset.fast_inter acc - (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in - metas := Mmap.add m t !metas; - find_all t)) in - OIdset.union (Some mset) all - ) None p t in - Option.get (OIdset.inter mset lset) - - let fold_pattern f acc p dn = fold_pattern ~complete:true f acc p dn - - let idset_map f is = Idset.fold (fun e acc -> Idset.add (f e) acc) is Idset.empty - let tmap_map f g m = Tmap.fold (fun k e acc -> Tmap.add (f k) (g e) acc) m Tmap.empty - - let rec map sidset sterm (Nodes (t,m)) : t = - let snode = function - | Terminal (e,is) -> Terminal (e,idset_map sidset is) - | Node e -> Node (T.map (map sidset sterm) e) in - Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m) - -end diff --git a/lib/dnet.mli b/lib/dnet.mli deleted file mode 100644 index 826e120a..00000000 --- a/lib/dnet.mli +++ /dev/null @@ -1,126 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** Generic discrimination net implementation over recursive - types. This module implements a association data structure similar - to tries but working on any types (not just lists). It is a term - indexing datastructure, a generalization of the discrimination nets - described for example in W.W.McCune, 1992, related also to - generalized tries [Hinze, 2000]. - - You can add pairs of (term,identifier) into a dnet, where the - identifier is *unique*, and search terms in a dnet filtering a - given pattern (retrievial of instances). It returns all identifiers - associated with terms matching the pattern. It also works the other - way around : You provide a set of patterns and a term, and it - returns all patterns which the term matches (retrievial of - generalizations). That's why you provide *patterns* everywhere. - - Warning 1: Full unification doesn't work as for now. Make sure the - set of metavariables in the structure and in the queries are - distincts, or you'll get unexpected behaviours. - - Warning 2: This structure is perfect, i.e. the set of candidates - returned is equal to the set of solutions. Beware of DeBruijn - shifts and sorts subtyping though (which makes the comparison not - symmetric, see term_dnet.ml). - - The complexity of the search is (almost) the depth of the term. - - To use it, you have to provide a module (Datatype) with the datatype - parametrized on the recursive argument. example: - - type btree = type 'a btree0 = - | Leaf ===> | Leaf - | Node of btree * btree | Node of 'a * 'a - -*) - -(** datatype you want to build a dnet on *) -module type Datatype = -sig - (** parametric datatype. ['a] is morally the recursive argument *) - type 'a t - - (** non-recursive mapping of subterms *) - val map : ('a -> 'b) -> 'a t -> 'b t - val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t - - (** non-recursive folding of subterms *) - val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a - val fold2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a - - (** comparison of constructors *) - val compare : unit t -> unit t -> int - - (** for each constructor, is it not-parametric on 'a? *) - val terminal : 'a t -> bool - - (** [choose f w] applies f on ONE of the subterms of w *) - val choose : ('a -> 'b) -> 'a t -> 'b -end - -module type S = -sig - type t - - (** provided identifier type *) - type ident - - (** provided metavariable type *) - type meta - - (** provided parametrized datastructure *) - type 'a structure - - (** returned sets of solutions *) - module Idset : Set.S with type elt=ident - - (** a pattern is a term where each node can be a unification - variable *) - type 'a pattern = - | Term of 'a - | Meta of meta - - type term_pattern = 'a structure pattern as 'a - - val empty : t - - (** [add t w i] adds a new association (w,i) in t. *) - val add : t -> term_pattern -> ident -> t - - (** [find_all t] returns all identifiers contained in t. *) - val find_all : t -> Idset.t - - (** [fold_pattern f acc p dn] folds f on each meta of p, passing the - meta and the sub-dnet under it. The result includes: - - Some set if identifiers were gathered on the leafs of the term - - None if the pattern contains no leaf (only Metas at the leafs). - *) - val fold_pattern : - ('a -> (Idset.t * meta * t) -> 'a) -> 'a -> term_pattern -> t -> Idset.t option * 'a - - (** [find_match p t] returns identifiers of all terms matching p in - t. *) - val find_match : term_pattern -> t -> Idset.t - - (** set operations on dnets *) - val inter : t -> t -> t - val union : t -> t -> t - - (** apply a function on each identifier and node of terms in a dnet *) - val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t -end - -module Make : - functor (T:Datatype) -> - functor (Ident:Set.OrderedType) -> - functor (Meta:Set.OrderedType) -> - S with type ident = Ident.t - and type meta = Meta.t - and type 'a structure = 'a T.t @@ -1,25 +1,49 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util +open Errors (* Dynamics, programmed with DANGER !!! *) -type t = string * Obj.t +type t = int * Obj.t -let dyntab = ref ([] : string list) +let dyntab = ref (Int.Map.empty : string Int.Map.t) +(** Instead of working with tags as strings, which are costly, we use their + hash. We ensure unicity of the hash in the [create] function. If ever a + collision occurs, which is unlikely, it is sufficient to tweak the offending + dynamic tag. *) -let create s = - if List.mem s !dyntab then - anomaly ("Dyn.create: already declared dynamic " ^ s); - dyntab := s :: !dyntab; - ((fun v -> (s,Obj.repr v)), - (fun (s',rv) -> - if s = s' then Obj.magic rv else failwith "dyn_out")) +let create (s : string) = + let hash = Hashtbl.hash s in + let () = + if Int.Map.mem hash !dyntab then + let old = Int.Map.find hash !dyntab in + let msg = Pp.str ("Dynamic tag collision: " ^ s ^ " vs. " ^ old) in + anomaly ~label:"Dyn.create" msg + in + let () = dyntab := Int.Map.add hash s !dyntab in + let infun v = (hash, Obj.repr v) in + let outfun (nh, rv) = + if Int.equal hash nh then Obj.magic rv + else + let msg = (Pp.str ("dyn_out: expected " ^ s)) in + anomaly msg + in + (infun, outfun) -let tag (s,_) = s +let has_tag (s, _) tag = + let hash = Hashtbl.hash (tag : string) in + Int.equal s hash + +let tag (s,_) = + try Int.Map.find s !dyntab + with Not_found -> + let msg = Pp.str ("Unknown dynamic tag " ^ (string_of_int s)) in + anomaly msg + +let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2 diff --git a/lib/dyn.mli b/lib/dyn.mli index 3ddde2b6..4a713472 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,3 +12,5 @@ type t val create : string -> ('a -> t) * (t -> 'a) val tag : t -> string +val has_tag : t -> string -> bool +val pointer_equal : t -> t -> bool diff --git a/lib/envars.ml b/lib/envars.ml index 3040dd41..b0eed838 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -1,130 +1,219 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* This file gathers environment variables needed by Coq to run (such - as coqlib) *) +open Util -let (//) s1 s2 = s1 ^ "/" ^ s2 +(** {1 Helper functions} *) -let coqbin = - System.canonical_path_name (Filename.dirname Sys.executable_name) +let getenv_else s dft = try Sys.getenv s with Not_found -> dft () -(* The following only makes sense when executables are running from - source tree (e.g. during build or in local mode). *) -let coqroot = Filename.dirname coqbin +let safe_getenv warning n = + getenv_else n (fun () -> + warning ("Environment variable "^n^" not found: using '$"^n^"' ."); + ("$"^n) + ) -(* On win32, we add coqbin to the PATH at launch-time (this used to be - done in a .bat script). *) +let ( / ) a b = + if Filename.is_relative b then a ^ "/" ^ b else b -let _ = - if Coq_config.arch = "win32" then - Unix.putenv "PATH" (coqbin ^ ";" ^ System.getenv_else "PATH" "") +let coqify d = d / "coq" -let exe s = s ^ Coq_config.exec_extension +let opt2list = function None -> [] | Some x -> [x] -let reldir instdir testfile oth = - let rpath = if Coq_config.local then [] else instdir in - let out = List.fold_left (//) coqroot rpath in - if Sys.file_exists (out//testfile) then out else oth () - -let guess_coqlib () = - let file = "states/initial.coq" in - reldir (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) file - (fun () -> - let coqlib = match Coq_config.coqlib with - | Some coqlib -> coqlib - | None -> coqroot - in - if Sys.file_exists (coqlib//file) - then coqlib - else Util.error "cannot guess a path for Coq libraries; please use -coqlib option") - -let coqlib () = - if !Flags.coqlib_spec then !Flags.coqlib else - (if !Flags.boot then coqroot else guess_coqlib ()) - -let docdir () = - reldir (if Coq_config.arch = "win32" then ["doc"] else ["share";"doc";"coq"]) "html" (fun () -> Coq_config.docdir) +let home ~warn = + getenv_else "HOME" (fun () -> + try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> + getenv_else "USERPROFILE" (fun () -> + warn ("Cannot determine user home directory, using '.' ."); + Filename.current_dir_name)) let path_to_list p = - let sep = if Sys.os_type = "Win32" then ';' else ':' in - Util.split_string_at sep p + let sep = if String.equal Sys.os_type "Win32" then ';' else ':' in + String.split sep p + +let user_path () = + path_to_list (Sys.getenv "PATH") (* may raise Not_found *) + +let rec which l f = + match l with + | [] -> + raise Not_found + | p :: tl -> + if Sys.file_exists (p / f) then + p + else + which tl f + +let expand_path_macros ~warn s = + let rec expand_atom s i = + let l = String.length s in + if i<l && (Util.is_digit s.[i] || Util.is_letter s.[i] || s.[i] == '_') + then expand_atom s (i+1) + else i in + let rec expand_macros s i = + let l = String.length s in + if Int.equal i l then s else + match s.[i] with + | '$' -> + let n = expand_atom s (i+1) in + let v = safe_getenv warn (String.sub s (i+1) (n-i-1)) in + let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in + expand_macros s (i + String.length v) + | '~' when Int.equal i 0 -> + let n = expand_atom s (i+1) in + let v = + if Int.equal n (i + 1) then home ~warn + else (Unix.getpwnam (String.sub s (i+1) (n-i-1))).Unix.pw_dir + in + let s = v^(String.sub s n (l-n)) in + expand_macros s (String.length v) + | c -> expand_macros s (i+1) + in expand_macros s 0 + +(** {1 Paths} *) + +(** {2 Coq paths} *) + +let relative_base = + Filename.dirname (Filename.dirname Sys.executable_name) -let xdg_data_home = - (System.getenv_else "XDG_DATA_HOME" (System.home//".local/share"))//"coq" +let coqbin = + CUnix.canonical_path_name (Filename.dirname Sys.executable_name) -let xdg_config_home = - (System.getenv_else "XDG_CONFIG_HOME" (System.home//".config"))//"coq" +(** The following only makes sense when executables are running from + source tree (e.g. during build or in local mode). *) +let coqroot = + Filename.dirname coqbin -let xdg_data_dirs = - (try - List.map (fun dir -> dir//"coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS")) - with Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]) - @ (match Coq_config.datadir with |None -> [] |Some datadir -> [datadir]) +(** On win32, we add coqbin to the PATH at launch-time (this used to be + done in a .bat script). *) +let _ = + if Coq_config.arch_is_win32 then + Unix.putenv "PATH" (coqbin ^ ";" ^ getenv_else "PATH" (fun () -> "")) + +(** [check_file_else ~dir ~file oth] checks if [file] exists in + the installation directory [dir] given relatively to [coqroot]. + If this Coq is only locally built, then [file] must be in [coqroot]. + If the check fails, then [oth ()] is evaluated. *) +let check_file_else ~dir ~file oth = + let path = if Coq_config.local then coqroot else coqroot / dir in + if Sys.file_exists (path / file) then path else oth () + +let guess_coqlib fail = + let prelude = "theories/Init/Prelude.vo" in + let dir = if Coq_config.arch_is_win32 then "lib" else "lib/coq" in + check_file_else ~dir ~file:prelude + (fun () -> + let coqlib = match Coq_config.coqlib with + | Some coqlib -> coqlib + | None -> coqroot + in + if Sys.file_exists (coqlib / prelude) then coqlib + else + fail "cannot guess a path for Coq libraries; please use -coqlib option") + +(** coqlib is now computed once during coqtop initialization *) + +let set_coqlib ~fail = + if not !Flags.coqlib_spec then + let lib = if !Flags.boot then coqroot else guess_coqlib fail in + Flags.coqlib := lib + +let coqlib () = !Flags.coqlib -let xdg_dirs = - let dirs = xdg_data_home :: xdg_data_dirs - in - List.rev (List.filter Sys.file_exists dirs) +let docdir () = + let dir = if Coq_config.arch_is_win32 then "doc" else "share/doc/coq" in + check_file_else ~dir ~file:"html" (fun () -> Coq_config.docdir) let coqpath = - try - let path = Sys.getenv "COQPATH" in - List.rev (List.filter Sys.file_exists (path_to_list path)) - with Not_found -> [] + let coqpath = getenv_else "COQPATH" (fun () -> "") in + let make_search_path path = + let paths = path_to_list path in + let valid_paths = List.filter Sys.file_exists paths in + List.rev valid_paths + in + make_search_path coqpath -let rec which l f = - match l with - | [] -> raise Not_found - | p :: tl -> - if Sys.file_exists (p//f) - then p - else which tl f +(** {2 Caml paths} *) -let guess_camlbin () = - let path = Sys.getenv "PATH" in (* may raise Not_found *) - let lpath = path_to_list path in - which lpath (exe "ocamlc") +let exe s = s ^ Coq_config.exec_extension -let guess_camlp4bin () = - let path = Sys.getenv "PATH" in (* may raise Not_found *) - let lpath = path_to_list path in - which lpath (exe Coq_config.camlp4) +let guess_camlbin () = which (user_path ()) (exe "ocamlc") let camlbin () = if !Flags.camlbin_spec then !Flags.camlbin else if !Flags.boot then Coq_config.camlbin else - try guess_camlbin () with e when e <> Sys.Break -> Coq_config.camlbin + try guess_camlbin () with Not_found -> Coq_config.camlbin + +let ocamlc () = camlbin () / Coq_config.ocamlc + +let ocamlopt () = camlbin () / Coq_config.ocamlopt let camllib () = - if !Flags.boot - then Coq_config.camllib + if !Flags.boot then + Coq_config.camllib else - let camlbin = camlbin () in - let com = (camlbin//"ocamlc") ^ " -where" in - let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in - Util.strip res + let _, res = CUnix.run_command (ocamlc () ^ " -where") in + String.strip res + +(** {2 Camlp4 paths} *) + +let guess_camlp4bin () = which (user_path ()) (exe Coq_config.camlp4) let camlp4bin () = if !Flags.camlp4bin_spec then !Flags.camlp4bin else if !Flags.boot then Coq_config.camlp4bin else - try guess_camlp4bin () with e when e <> Sys.Break -> + try guess_camlp4bin () + with Not_found -> let cb = camlbin () in - if Sys.file_exists (cb//(exe Coq_config.camlp4)) then cb - else Coq_config.camlp4bin + if Sys.file_exists (cb / exe Coq_config.camlp4) then cb + else Coq_config.camlp4bin + +let camlp4 () = camlp4bin () / exe Coq_config.camlp4 let camlp4lib () = - if !Flags.boot - then Coq_config.camlp4lib + if !Flags.boot then + Coq_config.camlp4lib else - let camlp4bin = camlp4bin () in - let com = (camlp4bin//Coq_config.camlp4) ^ " -where" in - let ex,res = System.run_command (fun x -> x) (fun _ -> ()) com in + let ex, res = CUnix.run_command (camlp4 () ^ " -where") in match ex with - |Unix.WEXITED 0 -> Util.strip res - |_ -> "/dev/null" + | Unix.WEXITED 0 -> String.strip res + | _ -> "/dev/null" + +(** {1 XDG utilities} *) + +let xdg_data_home warn = + coqify + (getenv_else "XDG_DATA_HOME" (fun () -> (home ~warn) / ".local/share")) + +let xdg_config_home warn = + coqify + (getenv_else "XDG_CONFIG_HOME" (fun () -> (home ~warn) / ".config")) + +let xdg_data_dirs warn = + let sys_dirs = + try + List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS")) + with + | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "share"] + | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"] + in + xdg_data_home warn :: sys_dirs @ opt2list Coq_config.datadir + +let xdg_config_dirs warn = + let sys_dirs = + try + List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) + with + | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "config"] + | Not_found -> ["/etc/xdg/coq"] + in + xdg_config_home warn :: sys_dirs @ opt2list Coq_config.configdir + +let xdg_dirs ~warn = + List.filter Sys.file_exists (xdg_data_dirs warn) diff --git a/lib/envars.mli b/lib/envars.mli index 023b54c0..b62b9f28 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -1,25 +1,80 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** This file gathers environment variables needed by Coq to run (such - as coqlib) *) +(** This file provides a high-level interface to the environment variables + needed by Coq to run (such as coqlib). The values of these variables + may come from different sources (shell environment variables, + command line options, options set at the time Coq was build). *) +(** [expand_path_macros warn s] substitutes environment variables + in a string by their values. This function also takes care of + substituting path of the form '~X' by an absolute path. + Use [warn] as a message displayer. *) +val expand_path_macros : warn:(string -> unit) -> string -> string + +(** [home warn] returns the root of the user directory, depending + on the OS. This information is usually stored in the $HOME + environment variable on POSIX shells. If no such variable + exists, then other common names are tried (HOMEDRIVE, HOMEPATH, + USERPROFILE). If all of them fail, [warn] is called. *) +val home : warn:(string -> unit) -> string + +(** [coqlib] is the path to the Coq library. *) val coqlib : unit -> string + +(** [set_coqlib] must be runned once before any access to [coqlib] *) +val set_coqlib : fail:(string -> string) -> unit + +(** [docdir] is the path to the Coq documentation. *) val docdir : unit -> string + +(** [coqbin] is the name of the current executable. *) val coqbin : string + +(** [coqroot] is the path to [coqbin]. + The following value only makes sense when executables are running from + source tree (e.g. during build or in local mode). +*) val coqroot : string -(* coqpath is stored in reverse order, since that is the order it - * gets added to the searc path *) -val xdg_config_home : string -val xdg_dirs : string list + +(** [coqpath] is the standard path to coq. + Notice that coqpath is stored in reverse order, since that is + the order it gets added to the search path. *) val coqpath : string list +(** [camlbin ()] is the path to the ocaml binaries. *) val camlbin : unit -> string -val camlp4bin : unit -> string + +(** [camllib ()] is the path to the ocaml standard library. *) val camllib : unit -> string + +(** [ocamlc ()] is the ocaml bytecode compiler that compiled this Coq. *) +val ocamlc : unit -> string + +(** [ocamlc ()] is the ocaml native compiler that compiled this Coq. *) +val ocamlopt : unit -> string + +(** [camlp4bin ()] is the path to the camlp4 binary. *) +val camlp4bin : unit -> string + +(** [camlp4lib ()] is the path to the camlp4 library. *) val camlp4lib : unit -> string + +(** [camlp4 ()] is the camlp4 utility. *) +val camlp4 : unit -> string + +(** Coq tries to honor the XDG Base Directory Specification to access + the user's configuration files. + + see [http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html] +*) +val xdg_config_home : (string -> unit) -> string +val xdg_data_home : (string -> unit) -> string +val xdg_config_dirs : (string -> unit) -> string list +val xdg_data_dirs : (string -> unit) -> string list +val xdg_dirs : warn : (string -> unit) -> string list diff --git a/lib/ephemeron.ml b/lib/ephemeron.ml new file mode 100644 index 00000000..b36904ca --- /dev/null +++ b/lib/ephemeron.ml @@ -0,0 +1,89 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type key_type = int + +type boxed_key = key_type ref ref + +let mk_key : unit -> boxed_key = + (* TODO: take a random value here. Is there a random function in OCaml? *) + let bid = ref 0 in + (* According to OCaml Gc module documentation, Pervasives.ref is one of the + few ways of getting a boxed value the compiler will never alias. *) + fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid) + +(* A phantom type to preserve type safety *) +type 'a key = boxed_key + +(* Comparing keys with == grants that if a key is unmarshalled (in the same + process where it was created or in another one) it is not mistaken for + an already existing one (unmarshal has no right to alias). If the initial + value of bid is taken at random, then one also avoids potential collisions *) +module HT = Hashtbl.Make(struct + type t = key_type ref + let equal k1 k2 = k1 == k2 + let hash id = !id +end) + +(* A key is the (unique) value inside a boxed key, hence it does not + keep its corresponding boxed key reachable (replacing key_type by boxed_key + would make the key always reachable) *) +let values : Obj.t HT.t = HT.create 1001 + +(* To avoid a race contidion between the finalization function and + get/create on the values hashtable, the finalization function just + enqueues in an imperative list the item to be collected. Being the list + imperative, even if the Gc enqueue an item while run_collection is operating, + the tail of the list is eventually set to Empty on completion. + Kudos to the authors of Why3 that came up with this solution for their + implementation of weak hash tables! *) +type imperative_list = cell ref +and cell = Empty | Item of key_type ref * imperative_list + +let collection_queue : imperative_list ref = ref (ref Empty) + +let enqueue x = collection_queue := ref (Item (!x, !collection_queue)) + +let run_collection () = + let rec aux l = match !l with + | Empty -> () + | Item (k, tl) -> HT.remove values k; aux tl in + let l = !collection_queue in + aux l; + l := Empty + +(* The only reference to the boxed key is the one returned, when the user drops + it the value eventually disappears from the values table above *) +let create (v : 'a) : 'a key = + run_collection (); + let k = mk_key () in + HT.add values !k (Obj.repr v); + Gc.finalise enqueue k; + k + +(* Avoid raising Not_found *) +exception InvalidKey +let get (k : 'a key) : 'a = + run_collection (); + try Obj.obj (HT.find values !k) + with Not_found -> raise InvalidKey + +(* Simple utils *) +let default k v = + try get k + with InvalidKey -> v + +let iter_opt k f = + match + try Some (get k) + with InvalidKey -> None + with + | None -> () + | Some v -> f v + +let clear () = run_collection () diff --git a/lib/ephemeron.mli b/lib/ephemeron.mli new file mode 100644 index 00000000..195b23db --- /dev/null +++ b/lib/ephemeron.mli @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Use case: + You have a data structure that needs to be marshalled but it contains + unmarshallable data (like a closure, or a file descriptor). Actually + you don't need this data to be preserved by marshalling, it just happens + to be there. + You could produced a trimmed down data structure, but then, once + unmarshalled, you can't used the very same code to process it, unless you + re-inject the trimmed down data structure into the standard one, using + dummy values for the unmarshallable stuff. + Similarly you could change your data structure turning all types [bad] + into [bad option], then just before marshalling you set all values of type + [bad option] to [None]. Still this pruning may be expensive and you have + to code it. + + Desiderata: + The marshalling operation automatically discards values that cannot be + marshalled or cannot be properly unmarshalled. + + Proposed solution: + Turn all occurrences of [bad] into [bad key] in your data structure. + Use [crate bad_val] to obtain a unique key [k] for [bad_val], and store + [k] in the data structure. Use [get k] to obtain [bad_val]. + + An ['a key] can always be marshalled. When marshalled, a key loses its + value. The function [get] raises Not_found on unmarshalled keys. + + If a key is garbage collected, the corresponding value is garbage + collected too (unless extra references to it exist). + In short no memory management hassle, keys can just replace their + corresponding value in the data structure. *) + +type 'a key + +val create : 'a -> 'a key + +(* May raise InvalidKey *) +exception InvalidKey +val get : 'a key -> 'a + +(* These never fail. *) +val iter_opt : 'a key -> ('a -> unit) -> unit +val default : 'a key -> 'a -> 'a + +val clear : unit -> unit diff --git a/lib/errors.ml b/lib/errors.ml index 6affea23..ab331d6a 100644 --- a/lib/errors.ml +++ b/lib/errors.ml @@ -8,8 +8,40 @@ open Pp -(* spiwack: it might be reasonable to decide and move the declarations - of Anomaly and so on to this module so as not to depend on Util. *) +(** Aliases *) + +let push = Backtrace.add_backtrace + +(* Errors *) + +exception Anomaly of string option * std_ppcmds (* System errors *) + +let make_anomaly ?label pp = + Anomaly (label, pp) + +let anomaly ?loc ?label pp = match loc with + | None -> raise (Anomaly (label, pp)) + | Some loc -> Loc.raise loc (Anomaly (label, pp)) + +let is_anomaly = function +| Anomaly _ -> true +| _ -> false + +exception UserError of string * std_ppcmds (* User errors *) +let error string = raise (UserError("_", str string)) +let errorlabstrm l pps = raise (UserError(l,pps)) + +exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) +let alreadydeclared pps = raise (AlreadyDeclared(pps)) + +let todo s = prerr_string ("TODO: "^s^"\n") + +let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm)) +let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s) + +exception Timeout +exception Drop +exception Quit let handle_stack = ref [] @@ -34,14 +66,24 @@ let rec print_gen bottom stk e = In usual situation, the [handle_stack] is treated as it if was always non-empty with [print_anomaly] as its bottom handler. *) -let where s = +let where = function +| None -> mt () +| Some s -> if !Flags.debug then str ("in "^s^":") ++ spc () else mt () let raw_anomaly e = match e with - | Util.Anomaly (s,pps) -> where s ++ pps ++ str "." + | Anomaly (s, pps) -> where s ++ pps ++ str "." | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e ^ ".") | _ -> str ("Uncaught exception " ^ Printexc.to_string e ^ ".") +let print_backtrace e = match Backtrace.get_backtrace e with +| None -> mt () +| Some bt -> + let bt = Backtrace.repr bt in + let pr_frame f = str (Backtrace.print_frame f) in + let bt = prlist_with_sep fnl pr_frame bt in + fnl () ++ hov 0 bt + let print_anomaly askreport e = if askreport then hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ str "Please report.") @@ -49,20 +91,20 @@ let print_anomaly askreport e = hov 0 (raw_anomaly e) (** The standard exception printer *) -let print e = print_gen (print_anomaly true) !handle_stack e +let print ?(info = Exninfo.null) e = + print_gen (print_anomaly true) !handle_stack e ++ print_backtrace info + +let iprint (e, info) = print ~info e (** Same as [print], except that the "Please report" part of an anomaly isn't printed (used in Ltac debugging). *) let print_no_report e = print_gen (print_anomaly false) !handle_stack e -(** Same as [print], except that anomalies are not printed but re-raised - (used for the Fail command) *) -let print_no_anomaly e = print_gen (fun e -> raise e) !handle_stack e - (** Predefined handlers **) let _ = register_handler begin function - | Util.UserError(s,pps) -> hov 0 (str "Error: " ++ where s ++ pps) + | UserError(s, pps) -> + hov 0 (str "Error: " ++ where (Some s) ++ pps) | _ -> raise Unhandled end @@ -70,10 +112,9 @@ end by inner functions during a [vernacinterp]. They should be handled only at the very end of interp, to be displayed to the user. *) -(** NB: in the 8.4 branch, for maximal compatibility, anomalies - are considered non-critical *) - let noncritical = function - | Sys.Break | Out_of_memory | Stack_overflow -> false + | Sys.Break | Out_of_memory | Stack_overflow + | Assert_failure _ | Match_failure _ | Anomaly _ + | Timeout | Drop | Quit -> false + | Invalid_argument "equal: functional value" -> false | _ -> true - diff --git a/lib/errors.mli b/lib/errors.mli index ae4d0b85..e4096a7e 100644 --- a/lib/errors.mli +++ b/lib/errors.mli @@ -6,9 +6,53 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) +open Pp + (** This modules implements basic manipulations of errors for use throughout Coq's code. *) +(** {6 Error handling} *) + +val push : exn -> Exninfo.iexn +(** Alias for [Backtrace.add_backtrace]. *) + +(** {6 Generic errors.} + + [Anomaly] is used for system errors and [UserError] for the + user's ones. *) + +val make_anomaly : ?label:string -> std_ppcmds -> exn +(** Create an anomaly. *) + +val anomaly : ?loc:Loc.t -> ?label:string -> std_ppcmds -> 'a +(** Raise an anomaly, with an optional location and an optional + label identifying the anomaly. *) + +val is_anomaly : exn -> bool +(** Check whether a given exception is an anomaly. + This is mostly provided for compatibility. Please avoid doing specific + tricks with anomalies thanks to it. See rather [noncritical] below. *) + +exception UserError of string * std_ppcmds +val error : string -> 'a +val errorlabstrm : string -> std_ppcmds -> 'a +val user_err_loc : Loc.t * string * std_ppcmds -> 'a + +exception AlreadyDeclared of std_ppcmds +val alreadydeclared : std_ppcmds -> 'a + +val invalid_arg_loc : Loc.t * string -> 'a + +(** [todo] is for running of an incomplete code its implementation is + "do nothing" (or print a message), but this function should not be + used in a released code *) + +val todo : string -> unit + +exception Timeout +exception Drop +exception Quit + (** [register_handler h] registers [h] as a handler. When an expression is printed with [print e], it goes through all registered handles (the most @@ -30,20 +74,16 @@ exception Unhandled val register_handler : (exn -> Pp.std_ppcmds) -> unit (** The standard exception printer *) -val print : exn -> Pp.std_ppcmds +val print : ?info:Exninfo.info -> exn -> Pp.std_ppcmds +val iprint : Exninfo.iexn -> Pp.std_ppcmds (** Same as [print], except that the "Please report" part of an anomaly isn't printed (used in Ltac debugging). *) val print_no_report : exn -> Pp.std_ppcmds -(** Same as [print], except that anomalies are not printed but re-raised - (used for the Fail command) *) -val print_no_anomaly : exn -> Pp.std_ppcmds - (** Critical exceptions shouldn't be catched and ignored by mistake by inner functions during a [vernacinterp]. They should be handled only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user. - Typical example: [Sys.Break]. In the 8.4 branch, for maximal - compatibility, anomalies are not considered as critical... + Typical example: [Sys.Break], [Assert_failure], [Anomaly] ... *) val noncritical : exn -> bool diff --git a/lib/exninfo.ml b/lib/exninfo.ml new file mode 100644 index 00000000..d049dc6c --- /dev/null +++ b/lib/exninfo.ml @@ -0,0 +1,104 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** Enriched exceptions have an additional field at the end of their usual data + containing a pair composed of the distinguishing [token] and the backtrace + information. We discriminate the token by pointer equality. *) + +module Store = Store.Make(struct end) + +type 'a t = 'a Store.field + +type info = Store.t + +type iexn = exn * info + +let make = Store.field +let add = Store.set +let get = Store.get +let null = Store.empty + +exception Unique + +let dummy = (Unique, Store.empty) + +let current : (int * iexn) list ref = ref [] +(** List associating to each thread id the latest exception raised by an + instrumented raise (i.e. {!raise} from this module). It is shared between + threads, so we must take care of this when modifying it. + + Invariants: all index keys are unique in the list. +*) + +let lock = Mutex.create () + +let rec remove_assoc (i : int) = function +| [] -> [] +| (j, v) :: rem as l -> + if i = j then rem + else + let ans = remove_assoc i rem in + if rem == ans then l + else (j, v) :: ans + +let rec find_and_remove_assoc (i : int) = function +| [] -> dummy, [] +| (j, v) :: rem as l -> + if i = j then (v, rem) + else + let (r, ans) = find_and_remove_assoc i rem in + if rem == ans then (r, l) + else (r, (j, v) :: ans) + +let iraise e = + let () = Mutex.lock lock in + let id = Thread.id (Thread.self ()) in + let () = current := (id, e) :: remove_assoc id !current in + let () = Mutex.unlock lock in + raise (fst e) + +let raise ?info e = match info with +| None -> + let () = Mutex.lock lock in + let id = Thread.id (Thread.self ()) in + let () = current := remove_assoc id !current in + let () = Mutex.unlock lock in + raise e +| Some i -> + let () = Mutex.lock lock in + let id = Thread.id (Thread.self ()) in + let () = current := (id, (e, i)) :: remove_assoc id !current in + let () = Mutex.unlock lock in + raise e + +let find_and_remove () = + let () = Mutex.lock lock in + let id = Thread.id (Thread.self ()) in + let (v, l) = find_and_remove_assoc id !current in + let () = current := l in + let () = Mutex.unlock lock in + v + +let info e = + let (src, data) = find_and_remove () in + if src == e then + (** Slightly unsound, some exceptions may not be unique up to pointer + equality. Though, it should be quite exceptional to be in a situation + where the following holds: + + 1. An argument-free exception is raised through the enriched {!raise}; + 2. It is not captured by any enriched with-clause (which would reset + the current data); + 3. The same exception is raised through the standard raise, accessing + the wrong data. + . *) + data + else + (** Mismatch: the raised exception is not the one stored, either because the + previous raise was not instrumented, or because something went wrong. *) + Store.empty diff --git a/lib/exninfo.mli b/lib/exninfo.mli new file mode 100644 index 00000000..c960ac7c --- /dev/null +++ b/lib/exninfo.mli @@ -0,0 +1,39 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** Additional information worn by exceptions. *) + +type 'a t +(** Information containing a given type. *) + +type info +(** All information *) + +type iexn = exn * info +(** Information-wearing exceptions *) + +val make : unit -> 'a t +(** Create a new piece of information. *) + +val null : info +(** No information *) + +val add : info -> 'a t -> 'a -> info +(** Add information to an exception. *) + +val get : info -> 'a t -> 'a option +(** Get information worn by an exception. Returns [None] if undefined. *) + +val info : exn -> info +(** Retrieve the information of the last exception raised. *) + +val iraise : iexn -> 'a +(** Raise the given enriched exception. *) + +val raise : ?info:info -> exn -> 'a +(** Raise the given exception with additional information. *) diff --git a/lib/explore.ml b/lib/explore.ml index 31a96774..3d57fc08 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -21,7 +21,7 @@ module Make = functor(S : SearchProblem) -> struct type position = int list - let msg_with_position p pp = + let msg_with_position (p : position) pp = let rec pp_rec = function | [] -> mt () | [i] -> int i @@ -50,7 +50,7 @@ module Make = functor(S : SearchProblem) -> struct in explore [1] s - (*s Breadth first search. We use functional FIFOS à la Okasaki. *) + (*s Breadth first search. We use functional FIFOS à la Okasaki. *) type 'a queue = 'a list * 'a list @@ -58,7 +58,7 @@ module Make = functor(S : SearchProblem) -> struct let empty = [],[] - let push x (h,t) = (x::h,t) + let push x (h,t) : _ queue = (x::h,t) let pop = function | h, x::t -> x, (h,t) diff --git a/lib/explore.mli b/lib/explore.mli index aaf11229..f3679188 100644 --- a/lib/explore.mli +++ b/lib/explore.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/feedback.ml b/lib/feedback.ml new file mode 100644 index 00000000..a5e16ea0 --- /dev/null +++ b/lib/feedback.ml @@ -0,0 +1,171 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype +open Serialize + +type message_level = + | Debug of string + | Info + | Notice + | Warning + | Error + +type message = { + message_level : message_level; + message_content : string; +} + +let of_message_level = function + | Debug s -> + Serialize.constructor "message_level" "debug" [Xml_datatype.PCData s] + | Info -> Serialize.constructor "message_level" "info" [] + | Notice -> Serialize.constructor "message_level" "notice" [] + | Warning -> Serialize.constructor "message_level" "warning" [] + | Error -> Serialize.constructor "message_level" "error" [] +let to_message_level = + Serialize.do_match "message_level" (fun s args -> match s with + | "debug" -> Debug (Serialize.raw_string args) + | "info" -> Info + | "notice" -> Notice + | "warning" -> Warning + | "error" -> Error + | _ -> raise Serialize.Marshal_error) + +let of_message msg = + let lvl = of_message_level msg.message_level in + let content = Serialize.of_string msg.message_content in + Xml_datatype.Element ("message", [], [lvl; content]) +let to_message xml = match xml with + | Xml_datatype.Element ("message", [], [lvl; content]) -> { + message_level = to_message_level lvl; + message_content = Serialize.to_string content } + | _ -> raise Serialize.Marshal_error + +let is_message = function + | Xml_datatype.Element ("message", _, _) -> true + | _ -> false + + +type edit_id = int +type state_id = Stateid.t +type edit_or_state_id = Edit of edit_id | State of state_id +type route_id = int + +type feedback_content = + | Processed + | Incomplete + | Complete + | ErrorMsg of Loc.t * string + | ProcessingIn of string + | InProgress of int + | WorkerStatus of string * string + | Goals of Loc.t * string + | AddedAxiom + | GlobRef of Loc.t * string * string * string * string + | GlobDef of Loc.t * string * string * string + | FileDependency of string option * string + | FileLoaded of string * string + | Custom of Loc.t * string * xml + | Message of message + +type feedback = { + id : edit_or_state_id; + contents : feedback_content; + route : route_id; +} + +let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with + | "addedaxiom", _ -> AddedAxiom + | "processed", _ -> Processed + | "processingin", [where] -> ProcessingIn (to_string where) + | "incomplete", _ -> Incomplete + | "complete", _ -> Complete + | "globref", [loc; filepath; modpath; ident; ty] -> + GlobRef(to_loc loc, to_string filepath, + to_string modpath, to_string ident, to_string ty) + | "globdef", [loc; ident; secpath; ty] -> + GlobDef(to_loc loc, to_string ident, to_string secpath, to_string ty) + | "errormsg", [loc; s] -> ErrorMsg (to_loc loc, to_string s) + | "inprogress", [n] -> InProgress (to_int n) + | "workerstatus", [ns] -> + let n, s = to_pair to_string to_string ns in + WorkerStatus(n,s) + | "goals", [loc;s] -> Goals (to_loc loc, to_string s) + | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x) + | "filedependency", [from; dep] -> + FileDependency (to_option to_string from, to_string dep) + | "fileloaded", [dirpath; filename] -> + FileLoaded (to_string dirpath, to_string filename) + | "message", [m] -> Message (to_message m) + | _ -> raise Marshal_error) +let of_feedback_content = function + | AddedAxiom -> constructor "feedback_content" "addedaxiom" [] + | Processed -> constructor "feedback_content" "processed" [] + | ProcessingIn where -> + constructor "feedback_content" "processingin" [of_string where] + | Incomplete -> constructor "feedback_content" "incomplete" [] + | Complete -> constructor "feedback_content" "complete" [] + | GlobRef(loc, filepath, modpath, ident, ty) -> + constructor "feedback_content" "globref" [ + of_loc loc; + of_string filepath; + of_string modpath; + of_string ident; + of_string ty ] + | GlobDef(loc, ident, secpath, ty) -> + constructor "feedback_content" "globdef" [ + of_loc loc; + of_string ident; + of_string secpath; + of_string ty ] + | ErrorMsg(loc, s) -> + constructor "feedback_content" "errormsg" [of_loc loc; of_string s] + | InProgress n -> constructor "feedback_content" "inprogress" [of_int n] + | WorkerStatus(n,s) -> + constructor "feedback_content" "workerstatus" + [of_pair of_string of_string (n,s)] + | Goals (loc,s) -> + constructor "feedback_content" "goals" [of_loc loc;of_string s] + | Custom (loc, name, x) -> + constructor "feedback_content" "custom" [of_loc loc; of_string name; x] + | FileDependency (from, depends_on) -> + constructor "feedback_content" "filedependency" [ + of_option of_string from; + of_string depends_on] + | FileLoaded (dirpath, filename) -> + constructor "feedback_content" "fileloaded" [ + of_string dirpath; + of_string filename ] + | Message m -> constructor "feedback_content" "message" [ of_message m ] + +let of_edit_or_state_id = function + | Edit id -> ["object","edit"], of_edit_id id + | State id -> ["object","state"], Stateid.to_xml id + +let of_feedback msg = + let content = of_feedback_content msg.contents in + let obj, id = of_edit_or_state_id msg.id in + let route = string_of_int msg.route in + Element ("feedback", obj @ ["route",route], [id;content]) +let to_feedback xml = match xml with + | Element ("feedback", ["object","edit";"route",route], [id;content]) -> { + id = Edit(to_edit_id id); + route = int_of_string route; + contents = to_feedback_content content } + | Element ("feedback", ["object","state";"route",route], [id;content]) -> { + id = State(Stateid.of_xml id); + route = int_of_string route; + contents = to_feedback_content content } + | _ -> raise Marshal_error + +let is_feedback = function + | Element ("feedback", _, _) -> true + | _ -> false + +let default_route = 0 diff --git a/lib/feedback.mli b/lib/feedback.mli new file mode 100644 index 00000000..52a0e9fe --- /dev/null +++ b/lib/feedback.mli @@ -0,0 +1,68 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype + +(* Old plain messages (used to be in Pp) *) +type message_level = + | Debug of string + | Info + | Notice + | Warning + | Error + +type message = { + message_level : message_level; + message_content : string; +} + +val of_message : message -> xml +val to_message : xml -> message +val is_message : xml -> bool + + +(** Coq "semantic" infos obtained during parsing/execution *) +type edit_id = int +type state_id = Stateid.t +type edit_or_state_id = Edit of edit_id | State of state_id +type route_id = int + +val default_route : route_id + +type feedback_content = + (* STM mandatory data (must be displayed) *) + | Processed + | Incomplete + | Complete + | ErrorMsg of Loc.t * string + (* STM optional data *) + | ProcessingIn of string + | InProgress of int + | WorkerStatus of string * string + (* Generally useful metadata *) + | Goals of Loc.t * string + | AddedAxiom + | GlobRef of Loc.t * string * string * string * string + | GlobDef of Loc.t * string * string * string + | FileDependency of string option * string + | FileLoaded of string * string + (* Extra metadata *) + | Custom of Loc.t * string * xml + (* Old generic messages *) + | Message of message + +type feedback = { + id : edit_or_state_id; (* The document part concerned *) + contents : feedback_content; (* The payload *) + route : route_id; (* Extra routing info *) +} + +val of_feedback : feedback -> xml +val to_feedback : xml -> feedback +val is_feedback : xml -> bool + diff --git a/lib/flags.ml b/lib/flags.ml index f6d98ba5..c8e7f7af 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,47 +8,116 @@ let with_option o f x = let old = !o in o:=true; - try let r = f x in o := old; r - with reraise -> o := old; raise reraise + try let r = f x in if !o = true then o := old; r + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = o := old in + Exninfo.iraise reraise + +let with_options ol f x = + let vl = List.map (!) ol in + let () = List.iter (fun r -> r := true) ol in + try + let r = f x in + let () = List.iter2 (:=) ol vl in r + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = List.iter2 (:=) ol vl in + Exninfo.iraise reraise let without_option o f x = let old = !o in o:=false; + try let r = f x in if !o = false then o := old; r + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = o := old in + Exninfo.iraise reraise + +let with_extra_values o l f x = + let old = !o in o:=old@l; try let r = f x in o := old; r - with reraise -> o := old; raise reraise + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = o := old in + Exninfo.iraise reraise let boot = ref false - +let load_init = ref true let batch_mode = ref false -let debug = ref false +type compilation_mode = BuildVo | BuildVio | Vio2Vo +let compilation_mode = ref BuildVo + +type async_proofs = APoff | APonLazy | APon +let async_proofs_mode = ref APoff +type cache = Force +let async_proofs_cache = ref None +let async_proofs_n_workers = ref 1 +let async_proofs_n_tacworkers = ref 2 +let async_proofs_private_flags = ref None +let async_proofs_full = ref false +let async_proofs_never_reopen_branch = ref false +let async_proofs_flags_for_workers = ref [] +let async_proofs_worker_id = ref "master" +type priority = Low | High +let async_proofs_worker_priority = ref Low +let string_of_priority = function Low -> "low" | High -> "high" +let priority_of_string = function + | "low" -> Low + | "high" -> High + | _ -> raise (Invalid_argument "priority_of_string") + +let async_proofs_is_worker () = + !async_proofs_worker_id <> "master" +let async_proofs_is_master () = + !async_proofs_mode = APon && !async_proofs_worker_id = "master" -let print_emacs = ref false +let debug = ref false +let in_debugger = ref false +let in_toplevel = ref false -let term_quality = ref false +let profile = false -let xml_export = ref false +let print_emacs = ref false +let coqtop_ui = ref false -type load_proofs = Force | Lazy | Dont +let ide_slave = ref false +let ideslave_coqtop_flags = ref None -let load_proofs = ref Lazy +let time = ref false let raw_print = ref false let record_print = ref true +let univ_print = ref false + +let we_are_parsing = ref false + (* Compatibility mode *) (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_2 | V8_3 | Current +type compat_version = V8_2 | V8_3 | V8_4 | Current + let compat_version = ref Current -let version_strictly_greater v = !compat_version > v + +let version_strictly_greater v = match !compat_version, v with +| V8_2, (V8_2 | V8_3 | V8_4 | Current) -> false +| V8_3, (V8_3 | V8_4 | Current) -> false +| V8_4, (V8_4 | Current) -> false +| Current, Current -> false +| V8_3, V8_2 -> true +| V8_4, (V8_2 | V8_3) -> true +| Current, (V8_2 | V8_3 | V8_4) -> true + let version_less_or_equal v = not (version_strictly_greater v) let pr_version = function | V8_2 -> "8.2" | V8_3 -> "8.3" + | V8_4 -> "8.4" | Current -> "current" (* Translate *) @@ -73,7 +142,23 @@ let auto_intros = ref true let make_auto_intros flag = auto_intros := flag let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros -let hash_cons_proofs = ref true +let universe_polymorphism = ref false +let make_universe_polymorphism b = universe_polymorphism := b +let is_universe_polymorphism () = !universe_polymorphism + +let local_polymorphic_flag = ref None +let use_polymorphic_flag () = + match !local_polymorphic_flag with + | Some p -> local_polymorphic_flag := None; p + | None -> is_universe_polymorphism () +let make_polymorphic_flag b = + local_polymorphic_flag := Some b + +(** [program_mode] tells that Program mode has been activated, either + globally via [Set Program] or locally via the Program command prefix. *) + +let program_mode = ref false +let is_program_mode () = !program_mode let warn = ref true let make_warn flag = warn := flag; () @@ -85,28 +170,8 @@ let print_hyps_limit = ref (None : int option) let set_print_hyps_limit n = print_hyps_limit := n let print_hyps_limit () = !print_hyps_limit -(* A list of the areas of the system where "unsafe" operation - * has been requested *) - -module Stringset = Set.Make(struct type t = string let compare = compare end) - -let unsafe_set = ref Stringset.empty -let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set -let is_unsafe s = Stringset.mem s !unsafe_set - (* Flags for external tools *) -let subst_command_placeholder s t = - let buff = Buffer.create (String.length s + String.length t) in - let i = ref 0 in - while (!i < String.length s) do - if s.[!i] = '%' & !i+1 < String.length s & s.[!i+1] = 's' - then (Buffer.add_string buff t;incr i) - else Buffer.add_char buff s.[!i]; - incr i - done; - Buffer.contents buff - let browser_cmd_fmt = try let coq_netscape_remote_var = "COQREMOTEBROWSER" in @@ -122,21 +187,9 @@ let is_standard_doc_url url = url = Coq_config.wwwrefman || url = wwwcompatprefix ^ String.sub Coq_config.wwwrefman n (n'-n) -(* same as in System, but copied here because of dependencies *) -let canonical_path_name p = - let current = Sys.getcwd () in - Sys.chdir p; - let result = Sys.getcwd () in - Sys.chdir current; - result - (* Options for changing coqlib *) let coqlib_spec = ref false -let coqlib = ref ( - (* same as Envars.coqroot, but copied here because of dependencies *) - Filename.dirname - (canonical_path_name (Filename.dirname Sys.executable_name)) -) +let coqlib = ref "(not initialized yet)" (* Options for changing camlbin (used by coqmktop) *) let camlbin_spec = ref false @@ -152,3 +205,11 @@ let default_inline_level = 100 let inline_level = ref default_inline_level let set_inline_level = (:=) inline_level let get_inline_level () = !inline_level + +(* Disabling native code compilation for conversion and normalization *) +let no_native_compiler = ref Coq_config.no_native_compiler + +(* Print the mod uid associated to a vo file by the native compiler *) +let print_mod_uid = ref false + +let tactic_context_compat = ref false diff --git a/lib/flags.mli b/lib/flags.mli index ede4629c..756d3b85 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,24 +9,51 @@ (** Global options of the system. *) val boot : bool ref +val load_init : bool ref val batch_mode : bool ref +type compilation_mode = BuildVo | BuildVio | Vio2Vo +val compilation_mode : compilation_mode ref + +type async_proofs = APoff | APonLazy | APon +val async_proofs_mode : async_proofs ref +type cache = Force +val async_proofs_cache : cache option ref +val async_proofs_n_workers : int ref +val async_proofs_n_tacworkers : int ref +val async_proofs_private_flags : string option ref +val async_proofs_is_worker : unit -> bool +val async_proofs_is_master : unit -> bool +val async_proofs_full : bool ref +val async_proofs_never_reopen_branch : bool ref +val async_proofs_flags_for_workers : string list ref +val async_proofs_worker_id : string ref +type priority = Low | High +val async_proofs_worker_priority : priority ref +val string_of_priority : priority -> string +val priority_of_string : string -> priority val debug : bool ref +val in_debugger : bool ref +val in_toplevel : bool ref + +val profile : bool val print_emacs : bool ref +val coqtop_ui : bool ref -val term_quality : bool ref +val ide_slave : bool ref +val ideslave_coqtop_flags : string option ref -val xml_export : bool ref +val time : bool ref -type load_proofs = Force | Lazy | Dont -val load_proofs : load_proofs ref +val we_are_parsing : bool ref val raw_print : bool ref val record_print : bool ref +val univ_print : bool ref -type compat_version = V8_2 | V8_3 | Current +type compat_version = V8_2 | V8_3 | V8_4 | Current val compat_version : compat_version ref val version_strictly_greater : compat_version -> bool val version_less_or_equal : compat_version -> bool @@ -48,25 +75,37 @@ val if_verbose : ('a -> unit) -> 'a -> unit val make_auto_intros : bool -> unit val is_auto_intros : unit -> bool +val program_mode : bool ref +val is_program_mode : unit -> bool + +(** Global universe polymorphism flag. *) +val make_universe_polymorphism : bool -> unit +val is_universe_polymorphism : unit -> bool + +(** Local universe polymorphism flag. *) +val make_polymorphic_flag : bool -> unit +val use_polymorphic_flag : unit -> bool + val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit -val hash_cons_proofs : bool ref - -(** Temporary activate an option (to activate option [o] on [f x y z], +(** Temporarily activate an option (to activate option [o] on [f x y z], use [with_option o (f x y) z]) *) val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b -(** Temporary deactivate an option *) +(** As [with_option], but on several flags. *) +val with_options : bool ref list -> ('a -> 'b) -> 'a -> 'b + +(** Temporarily deactivate an option *) val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b +(** Temporarily extends the reference to a list *) +val with_extra_values : 'c list ref -> 'c list -> ('a -> 'b) -> 'a -> 'b + (** If [None], no limit *) val set_print_hyps_limit : int option -> unit val print_hyps_limit : unit -> int option -val add_unsafe : string -> unit -val is_unsafe : string -> bool - (** Options for external tools *) (** Returns string format for default browser to use from Coq or CoqIDE *) @@ -74,9 +113,6 @@ val browser_cmd_fmt : string val is_standard_doc_url : string -> bool -(** Substitute %s in the first chain by the second chain *) -val subst_command_placeholder : string -> string -> string - (** Options for specifying where coq librairies reside *) val coqlib_spec : bool ref val coqlib : string ref @@ -91,3 +127,13 @@ val camlp4bin : string ref val set_inline_level : int -> unit val get_inline_level : unit -> int val default_inline_level : int + +(* Disabling native code compilation for conversion and normalization *) +val no_native_compiler : bool ref + +(* Print the mod uid associated to a vo file by the native compiler *) +val print_mod_uid : bool ref + +val tactic_context_compat : bool ref +(** Set to [true] to trigger the compatibility bugged context matching (old + context vs. appcontext) is set. *) diff --git a/lib/fmap.ml b/lib/fmap.ml deleted file mode 100644 index 8ca56fe7..00000000 --- a/lib/fmap.ml +++ /dev/null @@ -1,133 +0,0 @@ - -module Make = functor (X:Map.OrderedType) -> struct - type key = X.t - type 'a t = - Empty - | Node of 'a t * key * 'a * 'a t * int - - let empty = Empty - - let is_empty = function Empty -> true | _ -> false - - let height = function - Empty -> 0 - | Node(_,_,_,_,h) -> h - - let create l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let bal l x d r = - let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Map.bal" - | Node(ll, lv, ld, lr, _) -> - if height ll >= height lr then - create ll lv ld (create lr x d r) - else begin - match lr with - Empty -> invalid_arg "Map.bal" - | Node(lrl, lrv, lrd, lrr, _)-> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Map.bal" - | Node(rl, rv, rd, rr, _) -> - if height rr >= height rl then - create (create l x d rl) rv rd rr - else begin - match rl with - Empty -> invalid_arg "Map.bal" - | Node(rll, rlv, rld, rlr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - end - end else - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let rec add x data = function - Empty -> - Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> - let c = X.compare x v in - if c = 0 then - Node(l, x, data, r, h) - else if c < 0 then - bal (add x data l) v d r - else - bal l v d (add x data r) - - let rec find x = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - let c = X.compare x v in - if c = 0 then d - else find x (if c < 0 then l else r) - - let rec mem x = function - Empty -> - false - | Node(l, v, d, r, _) -> - let c = X.compare x v in - c = 0 || mem x (if c < 0 then l else r) - - let rec min_binding = function - Empty -> raise Not_found - | Node(Empty, x, d, r, _) -> (x, d) - | Node(l, x, d, r, _) -> min_binding l - - let rec remove_min_binding = function - Empty -> invalid_arg "Map.remove_min_elt" - | Node(Empty, x, d, r, _) -> r - | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r - - let merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (_, _) -> - let (x, d) = min_binding t2 in - bal t1 x d (remove_min_binding t2) - - let rec remove x = function - Empty -> - Empty - | Node(l, v, d, r, h) -> - let c = X.compare x v in - if c = 0 then - merge l r - else if c < 0 then - bal (remove x l) v d r - else - bal l v d (remove x r) - - let rec iter f = function - Empty -> () - | Node(l, v, d, r, _) -> - iter f l; f v d; iter f r - - let rec map f = function - Empty -> Empty - | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h) - - (* Maintien de fold_right par compatibilité (changé en fold_left dans - ocaml-3.09.0) *) - - let rec fold f m accu = - match m with - Empty -> accu - | Node(l, v, d, r, _) -> - fold f l (f v d (fold f r accu)) - -(* Added with respect to ocaml standard library. *) - - let dom m = fold (fun x _ acc -> x::acc) m [] - - let rng m = fold (fun _ y acc -> y::acc) m [] - - let to_list m = fold (fun x y acc -> (x,y)::acc) m [] - -end diff --git a/lib/fmap.mli b/lib/fmap.mli deleted file mode 100644 index 2c8dedd7..00000000 --- a/lib/fmap.mli +++ /dev/null @@ -1,23 +0,0 @@ - -module Make : functor (X : Map.OrderedType) -> -sig - type key = X.t - type 'a t - -val empty : 'a t -val is_empty : 'a t -> bool -val add : key -> 'a -> 'a t -> 'a t -val find : key -> 'a t -> 'a -val remove : key -> 'a t -> 'a t -val mem : key -> 'a t -> bool -val iter : (key -> 'a -> unit) -> 'a t -> unit -val map : ('a -> 'b) -> 'a t -> 'b t -val fold : (key -> 'a -> 'c -> 'c) -> 'a t -> 'c -> 'c - -(** Additions with respect to ocaml standard library. *) - -val dom : 'a t -> key list -val rng : 'a t -> 'a list -val to_list : 'a t -> (key * 'a) list -end - diff --git a/lib/fset.ml b/lib/fset.ml deleted file mode 100644 index 567feaa7..00000000 --- a/lib/fset.ml +++ /dev/null @@ -1,235 +0,0 @@ -module Make = functor (X : Set.OrderedType) -> -struct - - type elt = X.t - type t = Empty | Node of t * elt * t * int - - - (* Sets are represented by balanced binary trees (the heights of the - children differ by at most 2 *) - - let height = function - Empty -> 0 - | Node(_, _, _, h) -> h - - (* Creates a new node with left son l, value x and right son r. - l and r must be balanced and | height l - height r | <= 2. - Inline expansion of height for better speed. *) - - let create l x r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) - - (* Same as create, but performs one step of rebalancing if necessary. - Assumes l and r balanced. - Inline expansion of create for better speed in the most frequent case - where no rebalancing is required. *) - - let bal l x r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Set.bal" - | Node(ll, lv, lr, _) -> - if height ll >= height lr then - create ll lv (create lr x r) - else begin - match lr with - Empty -> invalid_arg "Set.bal" - | Node(lrl, lrv, lrr, _)-> - create (create ll lv lrl) lrv (create lrr x r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Set.bal" - | Node(rl, rv, rr, _) -> - if height rr >= height rl then - create (create l x rl) rv rr - else begin - match rl with - Empty -> invalid_arg "Set.bal" - | Node(rll, rlv, rlr, _) -> - create (create l x rll) rlv (create rlr rv rr) - end - end else - Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) - - (* Same as bal, but repeat rebalancing until the final result - is balanced. *) - - let rec join l x r = - match bal l x r with - Empty -> invalid_arg "Set.join" - | Node(l', x', r', _) as t' -> - let d = height l' - height r' in - if d < -2 or d > 2 then join l' x' r' else t' - - (* Merge two trees l and r into one. - All elements of l must precede the elements of r. - Assumes | height l - height r | <= 2. *) - - let rec merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - bal l1 v1 (bal (merge r1 l2) v2 r2) - - (* Same as merge, but does not assume anything about l and r. *) - - let rec concat t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - join l1 v1 (join (concat r1 l2) v2 r2) - - (* Splitting *) - - let rec split x = function - Empty -> - (Empty, None, Empty) - | Node(l, v, r, _) -> - let c = X.compare x v in - if c = 0 then (l, Some v, r) - else if c < 0 then - let (ll, vl, rl) = split x l in (ll, vl, join rl v r) - else - let (lr, vr, rr) = split x r in (join l v lr, vr, rr) - - (* Implementation of the set operations *) - - let empty = Empty - - let is_empty = function Empty -> true | _ -> false - - let rec mem x = function - Empty -> false - | Node(l, v, r, _) -> - let c = X.compare x v in - c = 0 || mem x (if c < 0 then l else r) - - let rec add x = function - Empty -> Node(Empty, x, Empty, 1) - | Node(l, v, r, _) as t -> - let c = X.compare x v in - if c = 0 then t else - if c < 0 then bal (add x l) v r else bal l v (add x r) - - let singleton x = Node(Empty, x, Empty, 1) - - let rec remove x = function - Empty -> Empty - | Node(l, v, r, _) -> - let c = X.compare x v in - if c = 0 then merge l r else - if c < 0 then bal (remove x l) v r else bal l v (remove x r) - - let rec union s1 s2 = - match (s1, s2) with - (Empty, t2) -> t2 - | (t1, Empty) -> t1 - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - if h1 >= h2 then - if h2 = 1 then add v2 s1 else begin - let (l2, _, r2) = split v1 s2 in - join (union l1 l2) v1 (union r1 r2) - end - else - if h1 = 1 then add v1 s2 else begin - let (l1, _, r1) = split v2 s1 in - join (union l1 l2) v2 (union r1 r2) - end - - let rec inter s1 s2 = - match (s1, s2) with - (Empty, t2) -> Empty - | (t1, Empty) -> Empty - | (Node(l1, v1, r1, _), t2) -> - match split v1 t2 with - (l2, None, r2) -> - concat (inter l1 l2) (inter r1 r2) - | (l2, Some _, r2) -> - join (inter l1 l2) v1 (inter r1 r2) - - let rec diff s1 s2 = - match (s1, s2) with - (Empty, t2) -> Empty - | (t1, Empty) -> t1 - | (Node(l1, v1, r1, _), t2) -> - match split v1 t2 with - (l2, None, r2) -> - join (diff l1 l2) v1 (diff r1 r2) - | (l2, Some _, r2) -> - concat (diff l1 l2) (diff r1 r2) - - let rec compare_aux l1 l2 = - match (l1, l2) with - ([], []) -> 0 - | ([], _) -> -1 - | (_, []) -> 1 - | (Empty :: t1, Empty :: t2) -> - compare_aux t1 t2 - | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) -> - let c = compare v1 v2 in - if c <> 0 then c else compare_aux (r1::t1) (r2::t2) - | (Node(l1, v1, r1, _) :: t1, t2) -> - compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2 - | (t1, Node(l2, v2, r2, _) :: t2) -> - compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2) - - let compare s1 s2 = - compare_aux [s1] [s2] - - let equal s1 s2 = - compare s1 s2 = 0 - - let rec subset s1 s2 = - match (s1, s2) with - Empty, _ -> - true - | _, Empty -> - false - | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> - let c = X.compare v1 v2 in - if c = 0 then - subset l1 l2 && subset r1 r2 - else if c < 0 then - subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 - else - subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 - - let rec iter f = function - Empty -> () - | Node(l, v, r, _) -> iter f l; f v; iter f r - - let rec fold f s accu = - match s with - Empty -> accu - | Node(l, v, r, _) -> fold f l (f v (fold f r accu)) - - let rec cardinal = function - Empty -> 0 - | Node(l, v, r, _) -> cardinal l + 1 + cardinal r - - let rec elements_aux accu = function - Empty -> accu - | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l - - let elements s = - elements_aux [] s - - let rec min_elt = function - Empty -> raise Not_found - | Node(Empty, v, r, _) -> v - | Node(l, v, r, _) -> min_elt l - - let rec max_elt = function - Empty -> raise Not_found - | Node(l, v, Empty, _) -> v - | Node(l, v, r, _) -> max_elt r - - let choose = min_elt -end diff --git a/lib/fset.mli b/lib/fset.mli deleted file mode 100644 index b1751d0b..00000000 --- a/lib/fset.mli +++ /dev/null @@ -1,25 +0,0 @@ -module Make : functor (X : Set.OrderedType) -> -sig - type elt = X.t - type t - -val empty : t -val is_empty : t -> bool -val mem : elt -> t -> bool -val add : elt -> t -> t -val singleton : elt -> t -val remove : elt -> t -> t -val union : t -> t -> t -val inter : t -> t -> t -val diff : t -> t -> t -val compare : t -> t -> int -val equal : t -> t -> bool -val subset : t -> t -> bool -val iter : ( elt -> unit) -> t -> unit -val fold : (elt -> 'b -> 'b) -> t -> 'b -> 'b -val cardinal : t -> int -val elements : t -> elt list -val min_elt : t -> elt -val max_elt : t -> elt -val choose : t -> elt -end diff --git a/lib/future.ml b/lib/future.ml new file mode 100644 index 00000000..2f1ce5e4 --- /dev/null +++ b/lib/future.ml @@ -0,0 +1,220 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* To deal with side effects we have to save/restore the system state *) +let freeze = ref (fun () -> assert false : unit -> Dyn.t) +let unfreeze = ref (fun _ -> () : Dyn.t -> unit) +let set_freeze f g = freeze := f; unfreeze := g + +exception NotReady +exception NotHere +let _ = Errors.register_handler (function + | NotReady -> + Pp.strbrk("The value you are asking for is not ready yet. " ^ + "Please wait or pass "^ + "the \"-async-proofs off\" option to CoqIDE to disable "^ + "asynchronous script processing.") + | NotHere -> + Pp.strbrk("The value you are asking for is not available "^ + "in this process. If you really need this, pass "^ + "the \"-async-proofs off\" option to CoqIDE to disable "^ + "asynchronous script processing.") + | _ -> raise Errors.Unhandled) + +type fix_exn = Exninfo.iexn -> Exninfo.iexn +let id x = prerr_endline "Future: no fix_exn.\nYou have probably created a Future.computation from a value without passing the ~fix_exn argument. You probably want to chain with an already existing future instead."; x + +module UUID = struct + type t = int + let invalid = 0 + let fresh = + let count = ref invalid in + fun () -> incr count; !count + + let compare = compare + let equal = (==) +end + +module UUIDMap = Map.Make(UUID) +module UUIDSet = Set.Make(UUID) + +type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] + +(* Val is not necessarily a final state, so the + computation restarts from the state stocked into Val *) +and 'a comp = + | Delegated of (unit -> unit) + | Closure of (unit -> 'a) + | Val of 'a * Dyn.t option + | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *) + +and 'a comput = + | Ongoing of (UUID.t * fix_exn * 'a comp ref) Ephemeron.key + | Finished of 'a + +and 'a computation = 'a comput ref + +let create ?(uuid=UUID.fresh ()) f x = + ref (Ongoing (Ephemeron.create (uuid, f, Pervasives.ref x))) +let get x = + match !x with + | Finished v -> UUID.invalid, id, ref (Val (v,None)) + | Ongoing x -> + try Ephemeron.get x + with Ephemeron.InvalidKey -> + UUID.invalid, id, ref (Exn (NotHere, Exninfo.null)) + +type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ] + +let is_over kx = let _, _, x = get kx in match !x with + | Val _ | Exn _ -> true + | Closure _ | Delegated _ -> false + +let is_val kx = let _, _, x = get kx in match !x with + | Val _ -> true + | Exn _ | Closure _ | Delegated _ -> false + +let is_exn kx = let _, _, x = get kx in match !x with + | Exn _ -> true + | Val _ | Closure _ | Delegated _ -> false + +let peek_val kx = let _, _, x = get kx in match !x with + | Val (v, _) -> Some v + | Exn _ | Closure _ | Delegated _ -> None + +let uuid kx = let id, _, _ = get kx in id + +let from_val ?(fix_exn=id) v = create fix_exn (Val (v, None)) +let from_here ?(fix_exn=id) v = create fix_exn (Val (v, Some (!freeze ()))) + +let fix_exn_of ck = let _, fix_exn, _ = get ck in fix_exn + +let create_delegate ?(blocking=true) fix_exn = + let assignement signal ck = fun v -> + let _, fix_exn, c = get ck in + assert (match !c with Delegated _ -> true | _ -> false); + begin match v with + | `Val v -> c := Val (v, None) + | `Exn e -> c := Exn (fix_exn e) + | `Comp f -> let _, _, comp = get f in c := !comp end; + signal () in + let wait, signal = + if not blocking then (fun () -> raise NotReady), ignore else + let lock = Mutex.create () in + let cond = Condition.create () in + (fun () -> Mutex.lock lock; Condition.wait cond lock; Mutex.unlock lock), + (fun () -> Mutex.lock lock; Condition.broadcast cond; Mutex.unlock lock) in + let ck = create fix_exn (Delegated wait) in + ck, assignement signal ck + +(* TODO: get rid of try/catch to be stackless *) +let rec compute ~pure ck : 'a value = + let _, fix_exn, c = get ck in + match !c with + | Val (x, _) -> `Val x + | Exn (e, info) -> `Exn (e, info) + | Delegated wait -> wait (); compute ~pure ck + | Closure f -> + try + let data = f () in + let state = if pure then None else Some (!freeze ()) in + c := Val (data, state); `Val data + with e -> + let e = Errors.push e in + let e = fix_exn e in + match e with + | (NotReady, _) -> `Exn e + | _ -> c := Exn e; `Exn e + +let force ~pure x = match compute ~pure x with + | `Val v -> v + | `Exn e -> Exninfo.iraise e + +let chain ~pure ck f = + let uuid, fix_exn, c = get ck in + create ~uuid fix_exn (match !c with + | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck)) + | Exn _ as x -> x + | Val (v, None) when pure -> Closure (fun () -> f v) + | Val (v, Some _) when pure -> Closure (fun () -> f v) + | Val (v, Some state) -> Closure (fun () -> !unfreeze state; f v) + | Val (v, None) -> + match !ck with + | Finished _ -> Errors.anomaly(Pp.str + "Future.chain ~pure:false call on an already joined computation") + | Ongoing _ -> Errors.anomaly(Pp.strbrk( + "Future.chain ~pure:false call on a pure computation. "^ + "This can happen if the computation was initial created with "^ + "Future.from_val or if it was Future.chain ~pure:true with a "^ + "function and later forced."))) + +let create fix_exn f = create fix_exn (Closure f) + +let replace kx y = + let _, _, x = get kx in + match !x with + | Exn _ -> x := Closure (fun () -> force ~pure:false y) + | _ -> Errors.anomaly + (Pp.str "A computation can be replaced only if is_exn holds") + +let purify f x = + let state = !freeze () in + try + let v = f x in + !unfreeze state; + v + with e -> + let e = Errors.push e in !unfreeze state; Exninfo.iraise e + +let transactify f x = + let state = !freeze () in + try f x + with e -> + let e = Errors.push e in !unfreeze state; Exninfo.iraise e + +let purify_future f x = if is_over x then f x else purify f x +let compute x = purify_future (compute ~pure:false) x +let force ~pure x = purify_future (force ~pure) x +let chain ?(greedy=true) ~pure x f = + let y = chain ~pure x f in + if is_over x && greedy then ignore(force ~pure y); + y +let force x = force ~pure:false x + +let join kx = + let v = force kx in + kx := Finished v; + v + +let sink kx = if is_val kx then ignore(join kx) + +let split2 ?greedy x = + chain ?greedy ~pure:true x (fun x -> fst x), + chain ?greedy ~pure:true x (fun x -> snd x) + +let map2 ?greedy f x l = + CList.map_i (fun i y -> + let xi = chain ?greedy ~pure:true x (fun x -> + try List.nth x i + with Failure _ | Invalid_argument _ -> + Errors.anomaly (Pp.str "Future.map2 length mismatch")) in + f xi y) 0 l + +let print f kx = + let open Pp in + let (uid, _, x) = get kx in + let uid = + if UUID.equal uid UUID.invalid then str "[#]" + else str "[" ++ int uid ++ str "]" + in + match !x with + | Delegated _ -> str "Delegated" ++ uid + | Closure _ -> str "Closure" ++ uid + | Val (x, None) -> str "PureVal" ++ uid ++ spc () ++ hov 0 (f x) + | Val (x, Some _) -> str "StateVal" ++ uid ++ spc () ++ hov 0 (f x) + | Exn (e, _) -> str "Exn" ++ uid ++ spc () ++ hov 0 (str (Printexc.to_string e)) diff --git a/lib/future.mli b/lib/future.mli new file mode 100644 index 00000000..8a4fa0bd --- /dev/null +++ b/lib/future.mli @@ -0,0 +1,162 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Futures: asynchronous computations with some purity enforcing + * + * A Future.computation is like a lazy_t but with some extra bells and whistles + * to deal with imperative code and eventual delegation to a slave process. + * + * Example of a simple scenario taken into account: + * + * let f = Future.from_here (number_of_constants (Global.env())) in + * let g = Future.chain ~pure:false f (fun n -> + * n = number_of_constants (Global.env())) in + * ... + * Lemmas.save_named ...; + * ... + * let b = Future.force g in + * + * The Future.computation f holds a (immediate, no lazy here) value. + * We then chain to obtain g that (will) hold false if (when it will be + * run) the global environment has a different number of constants, true + * if nothing changed. + * Before forcing g, we add to the global environment one more constant. + * When finally we force g. Its value is going to be *true*. + * This because Future.from_here stores in the computation not only the initial + * value but the entire system state. When g is forced the state is restored, + * hence Global.env() returns the environment that was actual when f was + * created. + * Last, forcing g is run protecting the system state, hence when g finishes, + * the actual system state is restored. + * + * If you compare this with lazy_t, you see that the value returned is *false*, + * that is counter intuitive and error prone. + * + * Still not all computations are impure and access/alter the system state. + * This class can be optimized by using ~pure:true, but there is no way to + * statically check if this flag is misused, hence use it with care. + * + * Other differences with lazy_t is that a future computation that produces + * and exception can be substituted for another computation of the same type. + * Moreover a future computation can be delegated to another execution entity + * that will be allowed to set the result. Finally future computations can + * always be marshalled: if they were joined before marshalling, they will + * hold the computed value (assuming it is itself marshallable), otherwise + * they will become invalid and accessing them raises a private exception. + *) + +(* Each computation has a unique id that is inherited by each offspring + * computation (chain, split, map...). Joined computations lose it. *) +module UUID : sig + type t + val invalid : t + + val compare : t -> t -> int + val equal : t -> t -> bool +end + +module UUIDMap : Map.S with type key = UUID.t +module UUIDSet : Set.S with type elt = UUID.t + +exception NotReady + +type 'a computation +type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ] +type fix_exn = Exninfo.iexn -> Exninfo.iexn + +(* Build a computation, no snapshot of the global state is taken. If you need + to grab a copy of the state start with from_here () and then chain. + fix_exn is used to enrich any exception raised + by forcing the computations or any computation that is chained after + it. It is used by STM to attach errors to their corresponding states, + and to communicate to the code catching the exception a valid state id. *) +val create : fix_exn -> (unit -> 'a) -> 'a computation + +(* Usually from_val is used to create "fake" futures, to use the same API + as if a real asynchronous computations was there. In this case fixing + the exception is not needed, but *if* the future is chained, the fix_exn + argument should really be given *) +val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation + +(* Like from_val, but also takes a snapshot of the global state. Morally + the value is not just the 'a but also the global system state *) +val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation + +(* To get the fix_exn of a computation and build a Tacexpr.declaration_hook. + * When a future enters the environment a corresponding hook is run to perform + * some work. If this fails, then its failure has to be annotated with the + * same state id that corresponds to the future computation end. I.e. Qed + * is split into two parts, the lazy one (the future) and the eagher one + * (the hook), both performing some computations for the same state id. *) +val fix_exn_of : 'a computation -> fix_exn + +(* Run remotely, returns the function to assign. + If not blocking (the default) it raises NotReady if forced before the + delage assigns it. *) +type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] +val create_delegate : + ?blocking:bool -> fix_exn -> 'a computation * ('a assignement -> unit) + +(* Given a computation that is_exn, replace it by another one *) +val replace : 'a computation -> 'a computation -> unit + +(* Inspect a computation *) +val is_over : 'a computation -> bool +val is_val : 'a computation -> bool +val is_exn : 'a computation -> bool +val peek_val : 'a computation -> 'a option +val uuid : 'a computation -> UUID.t + +(* [chain greedy pure c f] chains computation [c] with [f]. + * The [greedy] and [pure] parameters are tricky: + * [pure]: + * When pure is true, the returned computation will not keep a copy + * of the global state. + * [let c' = chain ~pure:true c f in let c'' = chain ~pure:false c' g in] + * is invalid. It works if one forces [c''] since the whole computation + * will be executed in one go. It will not work, and raise an anomaly, if + * one forces c' and then c''. + * [join c; chain ~pure:false c g] is invalid and fails at runtime. + * [force c; chain ~pure:false c g] is correct. + * [greedy]: + * The [greedy] parameter forces immediately the new computation if + * the old one is_over (Exn or Val). Defaults to true. *) +val chain : ?greedy:bool -> pure:bool -> + 'a computation -> ('a -> 'b) -> 'b computation + +(* Forcing a computation *) +val force : 'a computation -> 'a +val compute : 'a computation -> 'a value + +(* Final call, no more *inpure* chain allowed since the state is lost. + * Also the fix_exn function is lost, hence error reporting can be incomplete + * in a computation obtained by chaining on a joined future. *) +val join : 'a computation -> 'a + +(* Call this before stocking the future. If it is_val then it is joined *) +val sink : 'a computation -> unit + +(*** Utility functions ************************************************* ***) +val split2 : ?greedy:bool -> + ('a * 'b) computation -> 'a computation * 'b computation +val map2 : ?greedy:bool -> + ('a computation -> 'b -> 'c) -> + 'a list computation -> 'b list -> 'c list + +(* Once set_freeze is called we can purify a computation *) +val purify : ('a -> 'b) -> 'a -> 'b +(* And also let a function alter the state but backtrack if it raises exn *) +val transactify : ('a -> 'b) -> 'a -> 'b + +(** Debug: print a computation given an inner printing function. *) +val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds + +(* These functions are needed to get rid of side effects. + Thy are set for the outermos layer of the system, since they have to + deal with the whole system state. *) +val set_freeze : (unit -> Dyn.t) -> (Dyn.t -> unit) -> unit diff --git a/lib/genarg.ml b/lib/genarg.ml new file mode 100644 index 00000000..42458ecb --- /dev/null +++ b/lib/genarg.ml @@ -0,0 +1,235 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Util + +type argument_type = + (* Basic types *) + | IntOrVarArgType + | IdentArgType + | VarArgType + (* Specific types *) + | GenArgType + | ConstrArgType + | ConstrMayEvalArgType + | QuantHypArgType + | OpenConstrArgType + | ConstrWithBindingsArgType + | BindingsArgType + | RedExprArgType + | ListArgType of argument_type + | OptArgType of argument_type + | PairArgType of argument_type * argument_type + | ExtraArgType of string + +let rec argument_type_eq arg1 arg2 = match arg1, arg2 with +| IntOrVarArgType, IntOrVarArgType -> true +| IdentArgType, IdentArgType -> true +| VarArgType, VarArgType -> true +| GenArgType, GenArgType -> true +| ConstrArgType, ConstrArgType -> true +| ConstrMayEvalArgType, ConstrMayEvalArgType -> true +| QuantHypArgType, QuantHypArgType -> true +| OpenConstrArgType, OpenConstrArgType -> true +| ConstrWithBindingsArgType, ConstrWithBindingsArgType -> true +| BindingsArgType, BindingsArgType -> true +| RedExprArgType, RedExprArgType -> true +| ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 +| OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 +| PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) -> + argument_type_eq arg1l arg2l && argument_type_eq arg1r arg2r +| ExtraArgType s1, ExtraArgType s2 -> CString.equal s1 s2 +| _ -> false + +let rec pr_argument_type = function +| IntOrVarArgType -> str "int_or_var" +| IdentArgType -> str "ident" +| VarArgType -> str "var" +| GenArgType -> str "genarg" +| ConstrArgType -> str "constr" +| ConstrMayEvalArgType -> str "constr_may_eval" +| QuantHypArgType -> str "qhyp" +| OpenConstrArgType -> str "open_constr" +| ConstrWithBindingsArgType -> str "constr_with_bindings" +| BindingsArgType -> str "bindings" +| RedExprArgType -> str "redexp" +| ListArgType t -> pr_argument_type t ++ spc () ++ str "list" +| OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" +| PairArgType (t1, t2) -> + str "("++ pr_argument_type t1 ++ spc () ++ + str "*" ++ spc () ++ pr_argument_type t2 ++ str ")" +| ExtraArgType s -> str s + +type ('raw, 'glob, 'top) genarg_type = argument_type + +type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type +(** Alias for concision *) + +(* Dynamics but tagged by a type expression *) + +type rlevel +type glevel +type tlevel + +type 'a generic_argument = argument_type * Obj.t +type raw_generic_argument = rlevel generic_argument +type glob_generic_argument = glevel generic_argument +type typed_generic_argument = tlevel generic_argument + +let rawwit t = t +let glbwit t = t +let topwit t = t + +let wit_list t = ListArgType t + +let wit_opt t = OptArgType t + +let wit_pair t1 t2 = PairArgType (t1,t2) + +let in_gen t o = (t,Obj.repr o) +let out_gen t (t',o) = if argument_type_eq t t' then Obj.magic o else failwith "out_gen" +let genarg_tag (s,_) = s + +let has_type (t, v) u = argument_type_eq t u + +let unquote x = x + +type ('a,'b) abstract_argument_type = argument_type +type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type +type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type +type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type + +type ('a, 'b, 'c, 'l) cast = Obj.t + +let raw = Obj.obj +let glb = Obj.obj +let top = Obj.obj + +type ('r, 'l) unpacker = + { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r } + +let unpack pack (t, obj) = pack.unpacker t (Obj.obj obj) + +(** Type transformers *) + +type ('r, 'l) list_unpacker = + { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> + ('a list, 'b list, 'c list, 'l) cast -> 'r } + +let list_unpack pack (t, obj) = match t with +| ListArgType t -> pack.list_unpacker t (Obj.obj obj) +| _ -> failwith "out_gen" + +type ('r, 'l) opt_unpacker = + { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> + ('a option, 'b option, 'c option, 'l) cast -> 'r } + +let opt_unpack pack (t, obj) = match t with +| OptArgType t -> pack.opt_unpacker t (Obj.obj obj) +| _ -> failwith "out_gen" + +type ('r, 'l) pair_unpacker = + { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2. + ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> + (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r } + +let pair_unpack pack (t, obj) = match t with +| PairArgType (t1, t2) -> pack.pair_unpacker t1 t2 (Obj.obj obj) +| _ -> failwith "out_gen" + +(** Creating args *) + +let (arg0_map : Obj.t option String.Map.t ref) = ref String.Map.empty + +let create_arg opt name = + if String.Map.mem name !arg0_map then + Errors.anomaly (str "generic argument already declared: " ++ str name) + else + let () = arg0_map := String.Map.add name (Obj.magic opt) !arg0_map in + ExtraArgType name + +let make0 = create_arg + +let default_empty_value t = + let rec aux = function + | ListArgType _ -> Some (Obj.repr []) + | OptArgType _ -> Some (Obj.repr None) + | PairArgType(t1, t2) -> + (match aux t1, aux t2 with + | Some v1, Some v2 -> Some (Obj.repr (v1, v2)) + | _ -> None) + | ExtraArgType s -> + String.Map.find s !arg0_map + | _ -> None in + match aux t with + | Some v -> Some (Obj.obj v) + | None -> None + +(** Registering genarg-manipulating functions *) + +module type GenObj = +sig + type ('raw, 'glb, 'top) obj + val name : string + val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option +end + +module Register (M : GenObj) = +struct + let arg0_map = + ref (String.Map.empty : (Obj.t, Obj.t, Obj.t) M.obj String.Map.t) + + let register0 arg f = match arg with + | ExtraArgType s -> + if String.Map.mem s !arg0_map then + let msg = str M.name ++ str " function already registered: " ++ str s in + Errors.anomaly msg + else + arg0_map := String.Map.add s (Obj.magic f) !arg0_map + | _ -> assert false + + let get_obj0 name = + try String.Map.find name !arg0_map + with Not_found -> + match M.default (ExtraArgType name) with + | None -> + Errors.anomaly (str M.name ++ str " function not found: " ++ str name) + | Some obj -> obj + + (** For now, the following function is quite dummy and should only be applied + to an extra argument type, otherwise, it will badly fail. *) + let obj t = match t with + | ExtraArgType s -> Obj.magic (get_obj0 s) + | _ -> assert false + +end + +(** Hackish part *) + +let arg0_names = ref (String.Map.empty : string String.Map.t) +(** We use this table to associate a name to a given witness, to use it with + the extension mechanism. This is REALLY ad-hoc, but I do not know how to + do so nicely either. *) + +let register_name0 t name = match t with +| ExtraArgType s -> + let () = assert (not (String.Map.mem s !arg0_names)) in + arg0_names := String.Map.add s name !arg0_names +| _ -> failwith "register_name0" + +let get_name0 name = + String.Map.find name !arg0_names + +module Unsafe = +struct + +let inj tpe x = (tpe, x) +let prj (_, x) = x + +end diff --git a/lib/genarg.mli b/lib/genarg.mli new file mode 100644 index 00000000..a269f927 --- /dev/null +++ b/lib/genarg.mli @@ -0,0 +1,278 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** The route of a generic argument, from parsing to evaluation. +In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. + +{% \begin{%}verbatim{% }%} + parsing in_raw out_raw + char stream ---> raw_object ---> raw_object generic_argument -------+ + encapsulation decaps| + | + V + raw_object + | + globalization | + V + glob_object + | + encaps | + in_glob | + V + glob_object generic_argument + | + out in out_glob | + object <--- object generic_argument <--- object <--- glob_object <---+ + | decaps encaps interp decaps + | + V +effective use +{% \end{%}verbatim{% }%} + +To distinguish between the uninterpreted (raw), globalized and +interpreted worlds, we annotate the type [generic_argument] by a +phantom argument which is either [constr_expr], [glob_constr] or +[constr]. + +Transformation for each type : +{% \begin{%}verbatim{% }%} +tag raw open type cooked closed type + +BoolArgType bool bool +IntArgType int int +IntOrVarArgType int or_var int +StringArgType string (parsed w/ "") string +PreIdentArgType string (parsed w/o "") (vernac only) +IdentArgType true identifier identifier +IdentArgType false identifier (pattern_ident) identifier +IntroPatternArgType intro_pattern_expr intro_pattern_expr +VarArgType identifier located identifier +RefArgType reference global_reference +QuantHypArgType quantified_hypothesis quantified_hypothesis +ConstrArgType constr_expr constr +ConstrMayEvalArgType constr_expr may_eval constr +OpenConstrArgType open_constr_expr open_constr +ConstrWithBindingsArgType constr_expr with_bindings constr with_bindings +BindingsArgType constr_expr bindings constr bindings +List0ArgType of argument_type +List1ArgType of argument_type +OptArgType of argument_type +ExtraArgType of string '_a '_b +{% \end{%}verbatim{% }%} +*) + +(** {5 Generic types} *) + +type ('raw, 'glob, 'top) genarg_type +(** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized + one, and ['top] the internalized one. *) + +type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type +(** Alias for concision when the three types agree. *) + +val make0 : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type +(** Create a new generic type of argument: force to associate + unique ML types at each of the three levels. *) + +val create_arg : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type +(** Alias for [make0]. *) + +(** {5 Specialized types} *) + +(** All of [rlevel], [glevel] and [tlevel] must be non convertible + to ensure the injectivity of the type inference from type + ['co generic_argument] to [('a,'co) abstract_argument_type]; + this guarantees that, for 'co fixed, the type of + out_gen is monomorphic over 'a, hence type-safe +*) + +type rlevel +type glevel +type tlevel + +type ('a, 'co) abstract_argument_type +(** Type at level ['co] represented by an OCaml value of type ['a]. *) + +type 'a raw_abstract_argument_type = ('a, rlevel) abstract_argument_type +(** Specialized type at raw level. *) + +type 'a glob_abstract_argument_type = ('a, glevel) abstract_argument_type +(** Specialized type at globalized level. *) + +type 'a typed_abstract_argument_type = ('a, tlevel) abstract_argument_type +(** Specialized type at internalized level. *) + +(** {6 Projections} *) + +val rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type +(** Projection on the raw type constructor. *) + +val glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type +(** Projection on the globalized type constructor. *) + +val topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type +(** Projection on the internalized type constructor. *) + +(** {5 Generic arguments} *) + +type 'a generic_argument +(** A inhabitant of ['level generic_argument] is a inhabitant of some type at + level ['level], together with the representation of this type. *) + +type raw_generic_argument = rlevel generic_argument +type glob_generic_argument = glevel generic_argument +type typed_generic_argument = tlevel generic_argument + +(** {6 Constructors} *) + +val in_gen : ('a, 'co) abstract_argument_type -> 'a -> 'co generic_argument +(** [in_gen t x] embeds an argument of type [t] into a generic argument. *) + +val out_gen : ('a, 'co) abstract_argument_type -> 'co generic_argument -> 'a +(** [out_gen t x] recovers an argument of type [t] from a generic argument. It + fails if [x] has not the right dynamic type. *) + +val has_type : 'co generic_argument -> ('a, 'co) abstract_argument_type -> bool +(** [has_type v t] tells whether [v] has type [t]. If true, it ensures that + [out_gen t v] will not raise a dynamic type exception. *) + +(** {6 Destructors} *) + +type ('a, 'b, 'c, 'l) cast + +val raw : ('a, 'b, 'c, rlevel) cast -> 'a +val glb : ('a, 'b, 'c, glevel) cast -> 'b +val top : ('a, 'b, 'c, tlevel) cast -> 'c + +type ('r, 'l) unpacker = + { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r } + +val unpack : ('r, 'l) unpacker -> 'l generic_argument -> 'r +(** Existential-type destructors. *) + +(** {6 Manipulation of generic arguments} + +Those functions fail if they are applied to an argument which has not the right +dynamic type. *) + +type ('r, 'l) list_unpacker = + { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> + ('a list, 'b list, 'c list, 'l) cast -> 'r } + +val list_unpack : ('r, 'l) list_unpacker -> 'l generic_argument -> 'r + +type ('r, 'l) opt_unpacker = + { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> + ('a option, 'b option, 'c option, 'l) cast -> 'r } + +val opt_unpack : ('r, 'l) opt_unpacker -> 'l generic_argument -> 'r + +type ('r, 'l) pair_unpacker = + { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2. + ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> + (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r } + +val pair_unpack : ('r, 'l) pair_unpacker -> 'l generic_argument -> 'r + +(** {6 Type reification} *) + +type argument_type = + (** Basic types *) + | IntOrVarArgType + | IdentArgType + | VarArgType + (** Specific types *) + | GenArgType + | ConstrArgType + | ConstrMayEvalArgType + | QuantHypArgType + | OpenConstrArgType + | ConstrWithBindingsArgType + | BindingsArgType + | RedExprArgType + | ListArgType of argument_type + | OptArgType of argument_type + | PairArgType of argument_type * argument_type + | ExtraArgType of string + +val argument_type_eq : argument_type -> argument_type -> bool + +val pr_argument_type : argument_type -> Pp.std_ppcmds +(** Print a human-readable representation for a given type. *) + +val genarg_tag : 'a generic_argument -> argument_type + +val unquote : ('a, 'co) abstract_argument_type -> argument_type + +(** {6 Registering genarg-manipulating functions} + + This is boilerplate code used here and there in the code of Coq. *) + +module type GenObj = +sig + type ('raw, 'glb, 'top) obj + (** An object manipulating generic arguments. *) + + val name : string + (** A name for such kind of manipulation, e.g. [interp]. *) + + val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option + (** A generic object when there is no registered object for this type. *) +end + +module Register (M : GenObj) : +sig + val register0 : ('raw, 'glb, 'top) genarg_type -> + ('raw, 'glb, 'top) M.obj -> unit + (** Register a ground type manipulation function. *) + + val obj : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) M.obj + (** Recover a manipulation function at a given type. *) + +end + +(** {5 Basic generic type constructors} *) + +(** {6 Parameterized types} *) + +val wit_list : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type +val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type +val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> + ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type + +(** {5 Magic used by the parser} *) + +val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option + +val register_name0 : ('a, 'b, 'c) genarg_type -> string -> unit +(** Used by the extension to give a name to types. The string should be the + absolute path of the argument witness, e.g. + [register_name0 wit_toto "MyArg.wit_toto"]. *) + +val get_name0 : string -> string +(** Return the absolute path of a given witness. *) + +(** {5 Unsafe loophole} *) + +module Unsafe : +sig + +(** Unsafe magic functions. Not for kids. This is provided here as a loophole to + escape this module. Do NOT use outside of the dedicated areas. NOT. EVER. *) + +val inj : argument_type -> Obj.t -> 'lev generic_argument +(** Injects an object as generic argument. !!!BEWARE!!! only do this as + [inj tpe x] where: + + 1. [tpe] is the reification of a [('a, 'b, 'c) genarg_type]; + 2. [x] has type ['a], ['b] or ['c] according to the return level ['lev]. *) + +val prj : 'lev generic_argument -> Obj.t +(** Recover the contents of a generic argument. *) + +end diff --git a/lib/gmap.ml b/lib/gmap.ml deleted file mode 100644 index e1c68da0..00000000 --- a/lib/gmap.ml +++ /dev/null @@ -1,140 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Maps using the generic comparison function of ocaml. Code borrowed from - the ocaml standard library (Copyright 1996, INRIA). *) - - type ('a,'b) t = - Empty - | Node of ('a,'b) t * 'a * 'b * ('a,'b) t * int - - let empty = Empty - - let is_empty = function Empty -> true | _ -> false - - let height = function - Empty -> 0 - | Node(_,_,_,_,h) -> h - - let create l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let bal l x d r = - let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Map.bal" - | Node(ll, lv, ld, lr, _) -> - if height ll >= height lr then - create ll lv ld (create lr x d r) - else begin - match lr with - Empty -> invalid_arg "Map.bal" - | Node(lrl, lrv, lrd, lrr, _)-> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Map.bal" - | Node(rl, rv, rd, rr, _) -> - if height rr >= height rl then - create (create l x d rl) rv rd rr - else begin - match rl with - Empty -> invalid_arg "Map.bal" - | Node(rll, rlv, rld, rlr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - end - end else - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let rec add x data = function - Empty -> - Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> - let c = Pervasives.compare x v in - if c = 0 then - Node(l, x, data, r, h) - else if c < 0 then - bal (add x data l) v d r - else - bal l v d (add x data r) - - let rec find x = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - let c = Pervasives.compare x v in - if c = 0 then d - else find x (if c < 0 then l else r) - - let rec mem x = function - Empty -> - false - | Node(l, v, d, r, _) -> - let c = Pervasives.compare x v in - c = 0 || mem x (if c < 0 then l else r) - - let rec min_binding = function - Empty -> raise Not_found - | Node(Empty, x, d, r, _) -> (x, d) - | Node(l, x, d, r, _) -> min_binding l - - let rec remove_min_binding = function - Empty -> invalid_arg "Map.remove_min_elt" - | Node(Empty, x, d, r, _) -> r - | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r - - let merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (_, _) -> - let (x, d) = min_binding t2 in - bal t1 x d (remove_min_binding t2) - - let rec remove x = function - Empty -> - Empty - | Node(l, v, d, r, h) -> - let c = Pervasives.compare x v in - if c = 0 then - merge l r - else if c < 0 then - bal (remove x l) v d r - else - bal l v d (remove x r) - - let rec iter f = function - Empty -> () - | Node(l, v, d, r, _) -> - iter f l; f v d; iter f r - - let rec map f = function - Empty -> Empty - | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h) - - (* Maintien de fold_right par compatibilité (changé en fold_left dans - ocaml-3.09.0) *) - - let rec fold f m accu = - match m with - Empty -> accu - | Node(l, v, d, r, _) -> - fold f l (f v d (fold f r accu)) - -(* Added with respect to ocaml standard library. *) - - let dom m = fold (fun x _ acc -> x::acc) m [] - - let rng m = fold (fun _ y acc -> y::acc) m [] - - let to_list m = fold (fun x y acc -> (x,y)::acc) m [] - diff --git a/lib/gmap.mli b/lib/gmap.mli deleted file mode 100644 index c2fb7d26..00000000 --- a/lib/gmap.mli +++ /dev/null @@ -1,28 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** Maps using the generic comparison function of ocaml. Same interface as - the module [Map] from the ocaml standard library. *) - -type ('a,'b) t - -val empty : ('a,'b) t -val is_empty : ('a,'b) t -> bool -val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t -val find : 'a -> ('a,'b) t -> 'b -val remove : 'a -> ('a,'b) t -> ('a,'b) t -val mem : 'a -> ('a,'b) t -> bool -val iter : ('a -> 'b -> unit) -> ('a,'b) t -> unit -val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t -val fold : ('a -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c - -(** Additions with respect to ocaml standard library. *) - -val dom : ('a,'b) t -> 'a list -val rng : ('a,'b) t -> 'b list -val to_list : ('a,'b) t -> ('a * 'b) list diff --git a/lib/hMap.ml b/lib/hMap.ml new file mode 100644 index 00000000..f902eded --- /dev/null +++ b/lib/hMap.ml @@ -0,0 +1,332 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module type HashedType = +sig + type t + val compare : t -> t -> int + val hash : t -> int +end + +module SetMake(M : HashedType) = +struct + (** Hash Sets use hashes to prevent doing too many comparison tests. They + associate to each hash the set of keys having that hash. + + Invariants: + + 1. There is no empty set in the intmap. + 2. All values in the same set have the same hash, which is the int to + which it is associated in the intmap. + *) + + module Set = Set.Make(M) + + type elt = M.t + + type t = Set.t Int.Map.t + + let empty = Int.Map.empty + + let is_empty = Int.Map.is_empty + + let mem x s = + let h = M.hash x in + try + let m = Int.Map.find h s in + Set.mem x m + with Not_found -> false + + let add x s = + let h = M.hash x in + try + let m = Int.Map.find h s in + let m = Set.add x m in + Int.Map.update h m s + with Not_found -> + let m = Set.singleton x in + Int.Map.add h m s + + let singleton x = + let h = M.hash x in + let m = Set.singleton x in + Int.Map.singleton h m + + let remove x s = + let h = M.hash x in + try + let m = Int.Map.find h s in + let m = Set.remove x m in + if Set.is_empty m then + Int.Map.remove h s + else + Int.Map.update h m s + with Not_found -> s + + let union s1 s2 = + let fu _ m1 m2 = match m1, m2 with + | None, None -> None + | (Some _ as m), None | None, (Some _ as m) -> m + | Some m1, Some m2 -> Some (Set.union m1 m2) + in + Int.Map.merge fu s1 s2 + + let inter s1 s2 = + let fu _ m1 m2 = match m1, m2 with + | None, None -> None + | Some _, None | None, Some _ -> None + | Some m1, Some m2 -> + let m = Set.inter m1 m2 in + if Set.is_empty m then None else Some m + in + Int.Map.merge fu s1 s2 + + let diff s1 s2 = + let fu _ m1 m2 = match m1, m2 with + | None, None -> None + | (Some _ as m), None -> m + | None, Some _ -> None + | Some m1, Some m2 -> + let m = Set.diff m1 m2 in + if Set.is_empty m then None else Some m + in + Int.Map.merge fu s1 s2 + + let compare s1 s2 = Int.Map.compare Set.compare s1 s2 + + let equal s1 s2 = Int.Map.equal Set.equal s1 s2 + + let subset s1 s2 = + let check h m1 = + let m2 = try Int.Map.find h s2 with Not_found -> Set.empty in + Set.subset m1 m2 + in + Int.Map.for_all check s1 + + let iter f s = + let fi _ m = Set.iter f m in + Int.Map.iter fi s + + let fold f s accu = + let ff _ m accu = Set.fold f m accu in + Int.Map.fold ff s accu + + let for_all f s = + let ff _ m = Set.for_all f m in + Int.Map.for_all ff s + + let exists f s = + let fe _ m = Set.exists f m in + Int.Map.exists fe s + + let filter f s = + let ff m = Set.filter f m in + let s = Int.Map.map ff s in + Int.Map.filter (fun _ m -> not (Set.is_empty m)) s + + let partition f s = + let fold h m (sl, sr) = + let (ml, mr) = Set.partition f m in + let sl = if Set.is_empty ml then sl else Int.Map.add h ml sl in + let sr = if Set.is_empty mr then sr else Int.Map.add h mr sr in + (sl, sr) + in + Int.Map.fold fold s (Int.Map.empty, Int.Map.empty) + + let cardinal s = + let fold _ m accu = accu + Set.cardinal m in + Int.Map.fold fold s 0 + + let elements s = + let fold _ m accu = Set.fold (fun x accu -> x :: accu) m accu in + Int.Map.fold fold s [] + + let min_elt _ = assert false (** Cannot be implemented efficiently *) + + let max_elt _ = assert false (** Cannot be implemented efficiently *) + + let choose s = + let (_, m) = Int.Map.choose s in + Set.choose m + + let split s x = assert false (** Cannot be implemented efficiently *) + +end + +module Make(M : HashedType) = +struct + (** This module is essentially the same as SetMake, except that we have maps + instead of sets in the intmap. Invariants are the same. *) + module Set = SetMake(M) + module Map = CMap.Make(M) + + type key = M.t + + type 'a t = 'a Map.t Int.Map.t + + let empty = Int.Map.empty + + let is_empty = Int.Map.is_empty + + let mem k s = + let h = M.hash k in + try + let m = Int.Map.find h s in + Map.mem k m + with Not_found -> false + + let add k x s = + let h = M.hash k in + try + let m = Int.Map.find h s in + let m = Map.add k x m in + Int.Map.update h m s + with Not_found -> + let m = Map.singleton k x in + Int.Map.add h m s + + let singleton k x = + let h = M.hash k in + Int.Map.singleton h (Map.singleton k x) + + let remove k s = + let h = M.hash k in + try + let m = Int.Map.find h s in + let m = Map.remove k m in + if Map.is_empty m then + Int.Map.remove h s + else + Int.Map.update h m s + with Not_found -> s + + let merge f s1 s2 = + let fm h m1 m2 = match m1, m2 with + | None, None -> None + | Some m, None -> + let m = Map.merge f m Map.empty in + if Map.is_empty m then None + else Some m + | None, Some m -> + let m = Map.merge f Map.empty m in + if Map.is_empty m then None + else Some m + | Some m1, Some m2 -> + let m = Map.merge f m1 m2 in + if Map.is_empty m then None + else Some m + in + Int.Map.merge fm s1 s2 + + let compare f s1 s2 = + let fc m1 m2 = Map.compare f m1 m2 in + Int.Map.compare fc s1 s2 + + let equal f s1 s2 = + let fe m1 m2 = Map.equal f m1 m2 in + Int.Map.equal fe s1 s2 + + let iter f s = + let fi _ m = Map.iter f m in + Int.Map.iter fi s + + let fold f s accu = + let ff _ m accu = Map.fold f m accu in + Int.Map.fold ff s accu + + let for_all f s = + let ff _ m = Map.for_all f m in + Int.Map.for_all ff s + + let exists f s = + let fe _ m = Map.exists f m in + Int.Map.exists fe s + + let filter f s = + let ff m = Map.filter f m in + let s = Int.Map.map ff s in + Int.Map.filter (fun _ m -> not (Map.is_empty m)) s + + let partition f s = + let fold h m (sl, sr) = + let (ml, mr) = Map.partition f m in + let sl = if Map.is_empty ml then sl else Int.Map.add h ml sl in + let sr = if Map.is_empty mr then sr else Int.Map.add h mr sr in + (sl, sr) + in + Int.Map.fold fold s (Int.Map.empty, Int.Map.empty) + + let cardinal s = + let fold _ m accu = accu + Map.cardinal m in + Int.Map.fold fold s 0 + + let bindings s = + let fold _ m accu = Map.fold (fun k x accu -> (k, x) :: accu) m accu in + Int.Map.fold fold s [] + + let min_binding _ = assert false (** Cannot be implemented efficiently *) + + let max_binding _ = assert false (** Cannot be implemented efficiently *) + + let fold_left _ _ _ = assert false (** Cannot be implemented efficiently *) + + let fold_right _ _ _ = assert false (** Cannot be implemented efficiently *) + + let choose s = + let (_, m) = Int.Map.choose s in + Map.choose m + + let find k s = + let h = M.hash k in + let m = Int.Map.find h s in + Map.find k m + + let split k s = assert false (** Cannot be implemented efficiently *) + + let map f s = + let fs m = Map.map f m in + Int.Map.map fs s + + let mapi f s = + let fs m = Map.mapi f m in + Int.Map.map fs s + + let modify k f s = + let h = M.hash k in + let m = Int.Map.find h s in + let m = Map.modify k f m in + Int.Map.update h m s + + let bind f s = + let fb m = Map.bind f m in + Int.Map.map fb s + + let domain s = Int.Map.map Map.domain s + + let update k x s = + let h = M.hash k in + let m = Int.Map.find h s in + let m = Map.update k x m in + Int.Map.update h m s + + let smartmap f s = + let fs m = Map.smartmap f m in + Int.Map.smartmap fs s + + let smartmapi f s = + let fs m = Map.smartmapi f m in + Int.Map.smartmap fs s + + module Unsafe = + struct + let map f s = + let fs m = Map.Unsafe.map f m in + Int.Map.map fs s + end + +end diff --git a/lib/hMap.mli b/lib/hMap.mli new file mode 100644 index 00000000..cdf933b2 --- /dev/null +++ b/lib/hMap.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module type HashedType = +sig + type t + val compare : t -> t -> int + (** Total ordering *) + val hash : t -> int + (** Hashing function compatible with [compare], i.e. [compare x y = 0] implies + [hash x = hash y]. *) +end + +(** Hash maps are maps that take advantage of having a hash on keys. This is + essentially a hash table, except that it uses purely functional maps instead + of arrays. + + CAVEAT: order-related functions like [fold] or [iter] do not respect the + provided order anymore! It's your duty to do something sensible to prevent + this if you need it. In particular, [min_binding] and [max_binding] are now + made meaningless. +*) +module Make(M : HashedType) : CMap.ExtS with type key = M.t diff --git a/lib/hashcons.ml b/lib/hashcons.ml index d310713e..752e2634 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,42 +13,39 @@ (* [t] is the type of object to hash-cons * [u] is the type of hash-cons functions for the sub-structures * of objects of type t (u usually has the form (t1->t1)*(t2->t2)*...). - * [hash_sub u x] is a function that hash-cons the sub-structures of x using + * [hashcons u x] is a function that hash-cons the sub-structures of x using * the hash-consing functions u provides. * [equal] is a comparison function. It is allowed to use physical equality - * on the sub-terms hash-consed by the hash_sub function. + * on the sub-terms hash-consed by the hashcons function. * [hash] is the hash function given to the Hashtbl.Make function * * Note that this module type coerces to the argument of Hashtbl.Make. *) -module type Comp = +module type HashconsedType = sig type t type u - val hash_sub : u -> t -> t + val hashcons : u -> t -> t val equal : t -> t -> bool val hash : t -> int end -(* The output is a function f such that - * [f ()] has the side-effect of creating (internally) a hash-table of the - * hash-consed objects. The result is a function taking the sub-hashcons - * functions and an object, and hashcons it. It does not really make sense - * to call f() with different sub-hcons functions. That's why we use the - * wrappers simple_hcons, recursive_hcons, ... The latter just take as - * argument the sub-hcons functions (the tables are created at that moment), - * and returns the hcons function for t. - *) +(** The output is a function [generate] such that [generate args] creates a + hash-table of the hash-consed objects, together with [hcons], a function + taking a table and an object, and hashcons it. For simplicity of use, we use + the wrapper functions defined below. *) module type S = sig type t type u - val f : unit -> (u -> t -> t) + type table + val generate : u -> table + val hcons : table -> t -> t end -module Make(X:Comp) = +module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = struct type t = X.t type u = X.u @@ -58,34 +55,29 @@ module Make(X:Comp) = * w.r.t (=), although the equality on keys is X.equal. This is * granted since we hcons the subterms before looking up in the table. *) - module Htbl = Hashtbl.Make( - struct type t=X.t - type u=X.u - let hash=X.hash - let equal x1 x2 = (*incr comparaison;*) X.equal x1 x2 - end) - - (* The table is created when () is applied. - * Hashconsing is then very simple: - * 1- hashcons the subterms using hash_sub and u - * 2- look up in the table, if we do not get a hit, we add it - *) - let f () = + module Htbl = Hashset.Make(X) + + type table = (Htbl.t * u) + + let generate u = let tab = Htbl.create 97 in - (fun u x -> - let y = X.hash_sub u x in - (* incr acces;*) - try let r = Htbl.find tab y in(* incr succes;*) r - with Not_found -> Htbl.add tab y y; y) + (tab, u) + + let hcons (tab, u) x = + let y = X.hashcons u x in + Htbl.repr (X.hash y) y tab + end (* A few usefull wrappers: - * takes as argument the function f above and build a function of type + * takes as argument the function [generate] above and build a function of type * u -> t -> t that creates a fresh table each time it is applied to the * sub-hcons functions. *) (* For non-recursive types it is quite easy. *) -let simple_hcons h u = h () u +let simple_hcons h f u = + let table = h u in + fun x -> f table x (* For a recursive type T, we write the module of sig Comp with u equals * to (T -> T) * u0 @@ -93,28 +85,14 @@ let simple_hcons h u = h () u * The second one to hashcons the other sub-structures. * We just have to take the fixpoint of h *) -let recursive_hcons h u = - let hc = h () in - let rec hrec x = hc (hrec,u) x in +let recursive_hcons h f u = + let loop = ref (fun _ -> assert false) in + let self x = !loop x in + let table = h (self, u) in + let hrec x = f table x in + let () = loop := hrec in hrec -(* If the structure may contain loops, use this one. *) -let recursive_loop_hcons h u = - let hc = h () in - let rec hrec visited x = - if List.memq x visited then x - else hc (hrec (x::visited),u) x - in - hrec [] - -(* For 2 mutually recursive types *) -let recursive2_hcons h1 h2 u1 u2 = - let hc1 = h1 () in - let hc2 = h2 () in - let rec hrec1 x = hc1 (hrec1,hrec2,u1) x - and hrec2 x = hc2 (hrec1,hrec2,u2) x - in (hrec1,hrec2) - (* A set of global hashcons functions *) let hashcons_resets = ref [] let init() = List.iter (fun f -> f()) !hashcons_resets @@ -132,15 +110,48 @@ let register_hcons h u = (* Basic hashcons modules for string and obj. Integers do not need be hashconsed. *) +module type HashedType = sig type t val hash : t -> int end + +(* list *) +module Hlist (D:HashedType) = + Make( + struct + type t = D.t list + type u = (t -> t) * (D.t -> D.t) + let hashcons (hrec,hdata) = function + | x :: l -> hdata x :: hrec l + | l -> l + let equal l1 l2 = + l1 == l2 || + match l1, l2 with + | [], [] -> true + | x1::l1, x2::l2 -> x1==x2 && l1==l2 + | _ -> false + let rec hash accu = function + | [] -> accu + | x :: l -> + let accu = Hashset.Combine.combine (D.hash x) accu in + hash accu l + let hash l = hash 0 l + end) + (* string *) module Hstring = Make( struct type t = string type u = unit - let hash_sub () s =(* incr accesstr;*) s - let equal s1 s2 =(* incr comparaisonstr; - if*) s1=s2(* then (incr successtr; true) else false*) - let hash = Hashtbl.hash + let hashcons () s =(* incr accesstr;*) s + external equal : string -> string -> bool = "caml_string_equal" "noalloc" + (** Copy from CString *) + let rec hash len s i accu = + if i = len then accu + else + let c = Char.code (String.unsafe_get s i) in + hash len s (succ i) (accu * 19 + c) + + let hash s = + let len = String.length s in + hash len s 0 0 end) (* Obj.t *) @@ -148,10 +159,10 @@ exception NotEq (* From CAMLLIB/caml/mlvalues.h *) let no_scan_tag = 251 -let tuple_p obj = Obj.is_block obj & (Obj.tag obj < no_scan_tag) +let tuple_p obj = Obj.is_block obj && (Obj.tag obj < no_scan_tag) let comp_obj o1 o2 = - if tuple_p o1 & tuple_p o2 then + if tuple_p o1 && tuple_p o2 then let n1 = Obj.size o1 and n2 = Obj.size o2 in if n1=n2 then try @@ -176,7 +187,7 @@ module Hobj = Make( struct type t = Obj.t type u = (Obj.t -> Obj.t) * unit - let hash_sub (hrec,_) = hash_obj hrec + let hashcons (hrec,_) = hash_obj hrec let equal = comp_obj let hash = Hashtbl.hash end) @@ -186,8 +197,8 @@ module Hobj = Make( *) (* string : string -> string *) (* obj : Obj.t -> Obj.t *) -let string = register_hcons (simple_hcons Hstring.f) () -let obj = register_hcons (recursive_hcons Hobj.f) () +let string = register_hcons (simple_hcons Hstring.generate Hstring.hcons) () +let obj = register_hcons (recursive_hcons Hobj.generate Hobj.hcons) () (* The unsafe polymorphic hashconsing function *) let magic_hash (c : 'a) = diff --git a/lib/hashcons.mli b/lib/hashcons.mli index d2aa6462..60a9ee01 100644 --- a/lib/hashcons.mli +++ b/lib/hashcons.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,43 +8,81 @@ (** Generic hash-consing. *) -module type Comp = +(** {6 Hashconsing functorial interface} *) + +module type HashconsedType = sig + (** {6 Generic hashconsing signature} + + Given an equivalence relation [equal], a hashconsing function is a + function that associates the same canonical element to two elements + related by [equal]. Usually, the element chosen is canonical w.r.t. + physical equality [(==)], so as to reduce memory consumption and + enhance efficiency of equality tests. + + In order to ensure canonicality, we need a way to remember the element + associated to a class of equivalence; this is done using the table type + generated by the [Make] functor. + *) + type t + (** Type of objects to hashcons. *) type u - val hash_sub : u -> t -> t + (** Type of hashcons functions for the sub-structures contained in [t]. + Usually a tuple of functions. *) + val hashcons : u -> t -> t + (** The actual hashconsing function, using its fist argument to recursively + hashcons substructures. It should be compatible with [equal], that is + [equal x (hashcons f x) = true]. *) val equal : t -> t -> bool + (** A comparison function. It is allowed to use physical equality + on the sub-terms hashconsed by the [hashcons] function, but it should be + insensible to shallow copy of the compared object. *) val hash : t -> int + (** A hash function passed to the underlying hashtable structure. [hash] + should be compatible with [equal], i.e. if [equal x y = true] then + [hash x = hash y]. *) end module type S = sig type t + (** Type of objects to hashcons. *) type u - val f : unit -> (u -> t -> t) + (** Type of hashcons functions for the sub-structures contained in [t]. *) + type table + (** Type of hashconsing tables *) + val generate : u -> table + (** This create a hashtable of the hashconsed objects. *) + val hcons : table -> t -> t + (** Perform the hashconsing of the given object within the table. *) end -module Make(X:Comp) : (S with type t = X.t and type u = X.u) +module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) +(** Create a new hashconsing, given canonicalization functions. *) -val simple_hcons : (unit -> 'u -> 't -> 't) -> ('u -> 't -> 't) -val recursive_hcons : (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't) -val recursive_loop_hcons : - (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't) -val recursive2_hcons : - (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u1 -> 't1 -> 't1) -> - (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u2 -> 't2 -> 't2) -> - 'u1 -> 'u2 -> ('t1 -> 't1) * ('t2 -> 't2) +(** {6 Wrappers} *) -(** Declaring and reinitializing global hash-consing functions *) +(** These are intended to be used together with instances of the [Make] + functor. *) -val init : unit -> unit -val register_hcons : ('u -> 't -> 't) -> ('u -> 't -> 't) +val simple_hcons : ('u -> 'tab) -> ('tab -> 't -> 't) -> 'u -> 't -> 't +(** [simple_hcons f sub obj] creates a new table each time it is applied to any + sub-hash function [sub]. *) -module Hstring : (S with type t = string and type u = unit) -module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit) +val recursive_hcons : (('t -> 't) * 'u -> 'tab) -> ('tab -> 't -> 't) -> ('u -> 't -> 't) +(** As [simple_hcons] but intended to be used with well-founded data structures. *) + +(** {6 Hashconsing of usual structures} *) -val string : string -> string -val obj : Obj.t -> Obj.t +module type HashedType = sig type t val hash : t -> int end -val magic_hash : 'a -> 'a +module Hstring : (S with type t = string and type u = unit) +(** Hashconsing of strings. *) +module Hlist (D:HashedType) : + (S with type t = D.t list and type u = (D.t list -> D.t list)*(D.t->D.t)) +(** Hashconsing of lists. *) + +module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit) +(** Hashconsing of OCaml values. *) diff --git a/lib/hashset.ml b/lib/hashset.ml new file mode 100644 index 00000000..6bec81c7 --- /dev/null +++ b/lib/hashset.ml @@ -0,0 +1,203 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Adapted from Damien Doligez, projet Para, INRIA Rocquencourt, + OCaml stdlib. *) + +(** The following functor is a specialized version of [Weak.Make]. + Here, the responsibility of computing the hash function is now + given to the caller, which makes possible the interleaving of the + hash key computation and the hash-consing. *) + +module type EqType = sig + type t + val equal : t -> t -> bool +end + +module type S = sig + type elt + type t + val create : int -> t + val clear : t -> unit + val repr : int -> elt -> t -> elt +end + +module Make (E : EqType) = + struct + + type elt = E.t + + let emptybucket = Weak.create 0 + + type t = { + mutable table : elt Weak.t array; + mutable hashes : int array array; + mutable limit : int; (* bucket size limit *) + mutable oversize : int; (* number of oversize buckets *) + mutable rover : int; (* for internal bookkeeping *) + } + + let get_index t h = (h land max_int) mod (Array.length t.table) + + let limit = 7 + let over_limit = 2 + + let create sz = + let sz = if sz < 7 then 7 else sz in + let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in + { + table = Array.make sz emptybucket; + hashes = Array.make sz [| |]; + limit = limit; + oversize = 0; + rover = 0; + } + + let clear t = + for i = 0 to Array.length t.table - 1 do + t.table.(i) <- emptybucket; + t.hashes.(i) <- [| |]; + done; + t.limit <- limit; + t.oversize <- 0 + + let iter_weak f t = + let rec iter_bucket i j b = + if i >= Weak.length b then () else + match Weak.check b i with + | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b + | false -> iter_bucket (i+1) j b + in + for i = 0 to pred (Array.length t.table) do + iter_bucket 0 i (Array.unsafe_get t.table i) + done + + let rec count_bucket i b accu = + if i >= Weak.length b then accu else + count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0)) + + let min x y = if x - y < 0 then x else y + + let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length + let prev_sz n = ((n - 3) * 2 + 2) / 3 + + let test_shrink_bucket t = + let bucket = t.table.(t.rover) in + let hbucket = t.hashes.(t.rover) in + let len = Weak.length bucket in + let prev_len = prev_sz len in + let live = count_bucket 0 bucket 0 in + if live <= prev_len then begin + let rec loop i j = + if j >= prev_len then begin + if Weak.check bucket i then loop (i + 1) j + else if Weak.check bucket j then begin + Weak.blit bucket j bucket i 1; + hbucket.(i) <- hbucket.(j); + loop (i + 1) (j - 1); + end else loop i (j - 1); + end; + in + loop 0 (Weak.length bucket - 1); + if prev_len = 0 then begin + t.table.(t.rover) <- emptybucket; + t.hashes.(t.rover) <- [| |]; + end else begin + Obj.truncate (Obj.repr bucket) (prev_len + 1); + Obj.truncate (Obj.repr hbucket) prev_len; + end; + if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; + end; + t.rover <- (t.rover + 1) mod (Array.length t.table) + + let rec resize t = + let oldlen = Array.length t.table in + let newlen = next_sz oldlen in + if newlen > oldlen then begin + let newt = create newlen in + let add_weak ob oh oi = + let setter nb ni _ = Weak.blit ob oi nb ni 1 in + let h = oh.(oi) in + add_aux newt setter None h (get_index newt h); + in + iter_weak add_weak t; + t.table <- newt.table; + t.hashes <- newt.hashes; + t.limit <- newt.limit; + t.oversize <- newt.oversize; + t.rover <- t.rover mod Array.length newt.table; + end else begin + t.limit <- max_int; (* maximum size already reached *) + t.oversize <- 0; + end + + and add_aux t setter d h index = + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = Weak.length bucket in + let rec loop i = + if i >= sz then begin + let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in + if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more"; + let newbucket = Weak.create newsz in + let newhashes = Array.make newsz 0 in + Weak.blit bucket 0 newbucket 0 sz; + Array.blit hashes 0 newhashes 0 sz; + setter newbucket sz d; + newhashes.(sz) <- h; + t.table.(index) <- newbucket; + t.hashes.(index) <- newhashes; + if sz <= t.limit && newsz > t.limit then begin + t.oversize <- t.oversize + 1; + for i = 0 to over_limit do test_shrink_bucket t done; + end; + if t.oversize > Array.length t.table / over_limit then resize t + end else if Weak.check bucket i then begin + loop (i + 1) + end else begin + setter bucket i d; + hashes.(i) <- h + end + in + loop 0 + + let find_or h t d ifnotfound = + let index = get_index t h in + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = Weak.length bucket in + let rec loop i = + if i >= sz then ifnotfound index + else if h = hashes.(i) then begin + match Weak.get bucket i with + | Some v when E.equal v d -> v + | _ -> loop (i + 1) + end else loop (i + 1) + in + loop 0 + + let repr h d t = + let ifnotfound index = add_aux t Weak.set (Some d) h index; d in + find_or h t d ifnotfound + +end + +module Combine = struct + (* These are helper functions to combine the hash keys in a similar + way as [Hashtbl.hash] does. The constants [alpha] and [beta] must + be prime numbers. There were chosen empirically. Notice that the + problem of hashing trees is hard and there are plenty of study on + this topic. Therefore, there must be room for improvement here. *) + let alpha = 65599 + let beta = 7 + let combine x y = x * alpha + y + let combine3 x y z = combine x (combine y z) + let combine4 x y z t = combine x (combine3 y z t) + let combine5 x y z t u = combine x (combine4 y z t u) + let combinesmall x y = beta * x + y +end diff --git a/lib/hashset.mli b/lib/hashset.mli new file mode 100644 index 00000000..537f3418 --- /dev/null +++ b/lib/hashset.mli @@ -0,0 +1,47 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Adapted from Damien Doligez, projet Para, INRIA Rocquencourt, + OCaml stdlib. *) + +(** The following functor is a specialized version of [Weak.Make]. + Here, the responsibility of computing the hash function is now + given to the caller, which makes possible the interleaving of the + hash key computation and the hash-consing. *) + +module type EqType = sig + type t + val equal : t -> t -> bool +end + +module type S = sig + type elt + (** Type of hashsets elements. *) + type t + (** Type of hashsets. *) + val create : int -> t + (** [create n] creates a fresh hashset with initial size [n]. *) + val clear : t -> unit + (** Clear the contents of a hashset. *) + val repr : int -> elt -> t -> elt + (** [repr key constr set] uses [key] to look for [constr] + in the hashet [set]. If [constr] is in [set], returns the + specific representation that is stored in [set]. Otherwise, + [constr] is stored in [set] and will be used as the canonical + representation of this value in the future. *) +end + +module Make (E : EqType) : S with type elt = E.t + +module Combine : sig + val combine : int -> int -> int + val combinesmall : int -> int -> int + val combine3 : int -> int -> int -> int + val combine4 : int -> int -> int -> int -> int + val combine5 : int -> int -> int -> int -> int -> int +end diff --git a/lib/hashtbl_alt.ml b/lib/hashtbl_alt.ml deleted file mode 100644 index 14b439ec..00000000 --- a/lib/hashtbl_alt.ml +++ /dev/null @@ -1,109 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* The following module is a specialized version of [Hashtbl] that is - a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t] - with [constr] used both as a key and as an image. Thus, in each - cell of the internal bucketlist, there are two representations of - the same value. In this implementation, there is only one. - - Besides, the responsibility of computing the hash function is now - given to the caller, which makes possible the interleaving of the - hash key computation and the hash-consing. *) - -module type Hashtype = sig - type t - val equals : t -> t -> bool -end - -module type S = sig - type elt - (* [may_add_and_get key constr] uses [key] to look for [constr] - in the hash table [H]. If [constr] is in [H], returns the - specific representation that is stored in [H]. Otherwise, - [constr] is stored in [H] and will be used as the canonical - representation of this value in the future. *) - val may_add_and_get : int -> elt -> elt -end - -module Make (E : Hashtype) = - struct - - type elt = E.t - - type bucketlist = Empty | Cons of elt * int * bucketlist - - let initial_size = 19991 - let table_data = ref (Array.make initial_size Empty) - let table_size = ref 0 - - let resize () = - let odata = !table_data in - let osize = Array.length odata in - let nsize = min (2 * osize + 1) Sys.max_array_length in - if nsize <> osize then begin - let ndata = Array.create nsize Empty in - let rec insert_bucket = function - | Empty -> () - | Cons (key, hash, rest) -> - let nidx = hash mod nsize in - ndata.(nidx) <- Cons (key, hash, ndata.(nidx)); - insert_bucket rest - in - for i = 0 to osize - 1 do insert_bucket odata.(i) done; - table_data := ndata - end - - let add hash key = - let odata = !table_data in - let osize = Array.length odata in - let i = hash mod osize in - odata.(i) <- Cons (key, hash, odata.(i)); - incr table_size; - if !table_size > osize lsl 1 then resize () - - let find_rec hash key bucket = - let rec aux = function - | Empty -> - add hash key; key - | Cons (k, h, rest) -> - if hash == h && E.equals key k then k else aux rest - in - aux bucket - - let may_add_and_get hash key = - let odata = !table_data in - match odata.(hash mod (Array.length odata)) with - | Empty -> add hash key; key - | Cons (k1, h1, rest1) -> - if hash == h1 && E.equals key k1 then k1 else - match rest1 with - | Empty -> add hash key; key - | Cons (k2, h2, rest2) -> - if hash == h2 && E.equals key k2 then k2 else - match rest2 with - | Empty -> add hash key; key - | Cons (k3, h3, rest3) -> - if hash == h3 && E.equals key k3 then k3 - else find_rec hash key rest3 - -end - -module Combine = struct - (* These are helper functions to combine the hash keys in a similar - way as [Hashtbl.hash] does. The constants [alpha] and [beta] must - be prime numbers. There were chosen empirically. Notice that the - problem of hashing trees is hard and there are plenty of study on - this topic. Therefore, there must be room for improvement here. *) - let alpha = 65599 - let beta = 7 - let combine x y = x * alpha + y - let combine3 x y z = combine x (combine y z) - let combine4 x y z t = combine x (combine3 y z t) - let combinesmall x y = beta * x + y -end diff --git a/lib/hashtbl_alt.mli b/lib/hashtbl_alt.mli deleted file mode 100644 index f14fd90f..00000000 --- a/lib/hashtbl_alt.mli +++ /dev/null @@ -1,41 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* The following module is a specialized version of [Hashtbl] that is - a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t] - with [constr] used both as a key and as an image. Thus, in each - cell of the internal bucketlist, there are two representations of - the same value. In this implementation, there is only one. - - Besides, the responsibility of computing the hash function is now - given to the caller, which makes possible the interleaving of the - hash key computation and the hash-consing. *) - -module type Hashtype = sig - type t - val equals : t -> t -> bool -end - -module type S = sig - type elt - (* [may_add_and_get key constr] uses [key] to look for [constr] - in the hash table [H]. If [constr] is in [H], returns the - specific representation that is stored in [H]. Otherwise, - [constr] is stored in [H] and will be used as the canonical - representation of this value in the future. *) - val may_add_and_get : int -> elt -> elt -end - -module Make (E : Hashtype) : S with type elt = E.t - -module Combine : sig - val combine : int -> int -> int - val combinesmall : int -> int -> int - val combine3 : int -> int -> int -> int - val combine4 : int -> int -> int -> int -> int -end diff --git a/lib/heap.ml b/lib/heap.ml index 372cecfc..a19bc0d1 100644 --- a/lib/heap.ml +++ b/lib/heap.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -51,101 +51,86 @@ exception EmptyHeap module Functional(X : Ordered) = struct - (* Heaps are encoded as complete binary trees, i.e., binary trees - which are full expect, may be, on the bottom level where it is filled - from the left. - These trees also enjoy the heap property, namely the value of any node - is greater or equal than those of its left and right subtrees. - - There are 4 kinds of complete binary trees, denoted by 4 constructors: - [FFF] for a full binary tree (and thus 2 full subtrees); - [PPF] for a partial tree with a partial left subtree and a full - right subtree; - [PFF] for a partial tree with a full left subtree and a full right subtree - (but of different heights); - and [PFP] for a partial tree with a full left subtree and a partial - right subtree. *) + (* Heaps are encoded as Braun trees, that are binary trees + where size r <= size l <= size r + 1 for each node Node (l, x, r) *) type t = - | Empty - | FFF of t * X.t * t (* full (full, full) *) - | PPF of t * X.t * t (* partial (partial, full) *) - | PFF of t * X.t * t (* partial (full, full) *) - | PFP of t * X.t * t (* partial (full, partial) *) + | Leaf + | Node of t * X.t * t type elt = X.t - let empty = Empty + let empty = Leaf - (* smart constructors for insertion *) - let p_f l x r = match l with - | Empty | FFF _ -> PFF (l, x, r) - | _ -> PPF (l, x, r) - - let pf_ l x = function - | Empty | FFF _ as r -> FFF (l, x, r) - | r -> PFP (l, x, r) + let is_empty t = t = Leaf let rec add x = function - | Empty -> - FFF (Empty, x, Empty) - (* insertion to the left *) - | FFF (l, y, r) | PPF (l, y, r) -> - if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r - (* insertion to the right *) - | PFF (l, y, r) | PFP (l, y, r) -> - if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r) + | Leaf -> + Node (Leaf, x, Leaf) + | Node (l, y, r) -> + if X.compare x y >= 0 then + Node (add y r, x, l) + else + Node (add x r, y, l) + + let rec extract = function + | Leaf -> + assert false + | Node (Leaf, y, r) -> + assert (r = Leaf); + y, Leaf + | Node (l, y, r) -> + let x, l = extract l in + x, Node (r, y, l) + + let is_above x = function + | Leaf -> true + | Node (_, y, _) -> X.compare x y >= 0 + + let rec replace_min x = function + | Node (l, _, r) when is_above x l && is_above x r -> + Node (l, x, r) + | Node ((Node (_, lx, _) as l), _, r) when is_above lx r -> + (* lx <= x, rx necessarily *) + Node (replace_min x l, lx, r) + | Node (l, _, (Node (_, rx, _) as r)) -> + (* rx <= x, lx necessarily *) + Node (l, rx, replace_min x r) + | Leaf | Node (Leaf, _, _) | Node (_, _, Leaf) -> + assert false + + (* merges two Braun trees [l] and [r], + with the assumption that [size r <= size l <= size r + 1] *) + let rec merge l r = match l, r with + | _, Leaf -> + l + | Node (ll, lx, lr), Node (_, ly, _) -> + if X.compare lx ly >= 0 then + Node (r, lx, merge ll lr) + else + let x, l = extract l in + Node (replace_min x r, ly, l) + | Leaf, _ -> + assert false (* contradicts the assumption *) let maximum = function - | Empty -> raise EmptyHeap - | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x - - (* smart constructors for removal; note that they are different - from the ones for insertion! *) - let p_f l x r = match l with - | Empty | FFF _ -> FFF (l, x, r) - | _ -> PPF (l, x, r) - - let pf_ l x = function - | Empty | FFF _ as r -> PFF (l, x, r) - | r -> PFP (l, x, r) - - let rec remove = function - | Empty -> - raise EmptyHeap - | FFF (Empty, _, Empty) -> - Empty - | PFF (l, _, Empty) -> - l - (* remove on the left *) - | PPF (l, x, r) | PFF (l, x, r) -> - let xl = maximum l in - let xr = maximum r in - let l' = remove l in - if X.compare xl xr >= 0 then - p_f l' xl r - else - p_f l' xr (add xl (remove r)) - (* remove on the right *) - | FFF (l, x, r) | PFP (l, x, r) -> - let xl = maximum l in - let xr = maximum r in - let r' = remove r in - if X.compare xl xr > 0 then - pf_ (add xr (remove l)) xl r' - else - pf_ l xr r' + | Leaf -> raise EmptyHeap + | Node (_, x, _) -> x + + let remove = function + | Leaf -> + raise EmptyHeap + | Node (l, _, r) -> + merge l r let rec iter f = function - | Empty -> - () - | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> - iter f l; f x; iter f r + | Leaf -> () + | Node (l, x, r) -> iter f l; f x; iter f r let rec fold f h x0 = match h with - | Empty -> + | Leaf -> x0 - | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + | Node (l, x, r) -> fold f l (fold f r (f x x0)) end diff --git a/lib/heap.mli b/lib/heap.mli index ee86e814..a69de34c 100644 --- a/lib/heap.mli +++ b/lib/heap.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/hook.ml b/lib/hook.ml new file mode 100644 index 00000000..0aa373c2 --- /dev/null +++ b/lib/hook.ml @@ -0,0 +1,32 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type 'a content = +| Unset +| Default of 'a +| Set of 'a + +type 'a t = 'a content ref + +type 'a value = 'a t + +let get (hook : 'a value) = match !hook with +| Unset -> assert false +| Default data | Set data -> data + +let set (hook : 'a t) data = match !hook with +| Unset | Default _ -> hook := Set data +| Set _ -> assert false + +let make ?default () = + let data = match default with + | None -> Unset + | Some data -> Default data + in + let ans = ref data in + (ans, ans) diff --git a/lib/hook.mli b/lib/hook.mli new file mode 100644 index 00000000..d10f2c86 --- /dev/null +++ b/lib/hook.mli @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This module centralizes the notions of hooks. Hooks are pointers that are to + be set at runtime exactly once. *) + +type 'a t +(** The type of hooks containing ['a]. Hooks can only be set. *) + +type 'a value +(** The content part of a hook. *) + +val make : ?default:'a -> unit -> ('a value * 'a t) +(** Create a new hook together with a way to retrieve its runtime value. *) + +val get : 'a value -> 'a +(** Access the content of a hook. If it was not set yet, try to recover the + default value if there is one. + @raise Assert_failure if undefined. *) + +val set : 'a t -> 'a -> unit +(** Register a hook. Assertion failure if already registered. *) diff --git a/lib/iStream.ml b/lib/iStream.ml new file mode 100644 index 00000000..f9351d4b --- /dev/null +++ b/lib/iStream.ml @@ -0,0 +1,90 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type ('a,'r) u = +| Nil +| Cons of 'a * 'r + +type 'a node = ('a,'a t) u + +and 'a t = 'a node Lazy.t + +let empty = Lazy.lazy_from_val Nil + +let cons x s = Lazy.lazy_from_val (Cons (x, s)) + +let thunk = Lazy.lazy_from_fun + +let rec make_node f s = match f s with +| Nil -> Nil +| Cons (x, s) -> Cons (x, make f s) + +and make f s = lazy (make_node f s) + +let rec force s = match Lazy.force s with +| Nil -> () +| Cons (_, s) -> force s + +let force s = force s; s + +let is_empty s = match Lazy.force s with +| Nil -> true +| Cons (_, _) -> false + +let peek = Lazy.force + +let rec of_list = function +| [] -> empty +| x :: l -> cons x (of_list l) + +let rec to_list s = match Lazy.force s with +| Nil -> [] +| Cons (x, s) -> x :: (to_list s) + +let rec iter f s = match Lazy.force s with +| Nil -> () +| Cons (x, s) -> f x; iter f s + +let rec map_node f = function +| Nil -> Nil +| Cons (x, s) -> Cons (f x, map f s) + +and map f s = lazy (map_node f (Lazy.force s)) + +let rec app_node n1 s2 = match n1 with +| Nil -> Lazy.force s2 +| Cons (x, s1) -> Cons (x, app s1 s2) + +and app s1 s2 = lazy (app_node (Lazy.force s1) s2) + +let rec fold f accu s = match Lazy.force s with +| Nil -> accu +| Cons (x, s) -> fold f (f accu x) s + +let rec map_filter_node f = function +| Nil -> Nil +| Cons (x, s) -> + begin match f x with + | None -> map_filter_node f (Lazy.force s) + | Some y -> Cons (y, map_filter f s) + end + +and map_filter f s = lazy (map_filter_node f (Lazy.force s)) + +let rec concat_node = function +| Nil -> Nil +| Cons (s, sl) -> app_node (Lazy.force s) (concat sl) + +and concat (s : 'a t t) = + lazy (concat_node (Lazy.force s)) + +let rec concat_map_node f = function +| Nil -> Nil +| Cons (x,s) -> app_node (Lazy.force (f x)) (concat_map f s) + +and concat_map f l = lazy (concat_map_node f (Lazy.force l)) diff --git a/lib/iStream.mli b/lib/iStream.mli new file mode 100644 index 00000000..8cb12af4 --- /dev/null +++ b/lib/iStream.mli @@ -0,0 +1,81 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** {5 Purely functional streams} + + Contrarily to OCaml module [Stream], these are meant to be used purely + functionally. This implies in particular that accessing an element does not + discard it. *) + +type +'a t +(** Type of pure streams. *) + +type ('a,'r) u = +| Nil +| Cons of 'a * 'r +(** View type to decompose and build streams. *) + +(** {6 Constructors} *) + +val empty : 'a t +(** The empty stream. *) + +val cons : 'a -> 'a t -> 'a t +(** Append an element in front of a stream. *) + +val thunk : (unit -> ('a,'a t) u) -> 'a t +(** Internalize the lazyness of a stream. *) + +val make : ('a -> ('b, 'a) u) -> 'a -> 'b t +(** Coiteration constructor. *) + +(** {6 Destructors} *) + +val is_empty : 'a t -> bool +(** Whethere a stream is empty. *) + +val peek : 'a t -> ('a , 'a t) u +(** Return the head and the tail of a stream, if any. *) + +(** {6 Standard operations} + + All stream-returning functions are lazy. The other ones are eager. *) + +val app : 'a t -> 'a t -> 'a t +(** Append two streams. Not tail-rec. *) + +val map : ('a -> 'b) -> 'a t -> 'b t +(** Mapping of streams. Not tail-rec. *) + +val iter : ('a -> unit) -> 'a t -> unit +(** Iteration over streams. *) + +val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a +(** Fold over streams. *) + +val concat : 'a t t -> 'a t +(** Appends recursively a stream of streams. *) + +val map_filter : ('a -> 'b option) -> 'a t -> 'b t +(** Mixing [map] and [filter]. Not tail-rec. *) + +val concat_map : ('a -> 'b t) -> 'a t -> 'b t +(** [concat_map f l] is the same as [concat (map f l)]. *) + +(** {6 Conversions} *) + +val of_list : 'a list -> 'a t +(** Convert a list into a stream. *) + +val to_list : 'a t -> 'a list +(** Convert a stream into a list. *) + +(** {6 Other}*) + +val force : 'a t -> 'a t +(** Forces the whole stream. *) diff --git a/lib/int.ml b/lib/int.ml new file mode 100644 index 00000000..d9917657 --- /dev/null +++ b/lib/int.ml @@ -0,0 +1,237 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type t = int + +external equal : int -> int -> bool = "%eq" + +external compare : int -> int -> int = "caml_int_compare" + +let hash i = i land 0x3FFFFFFF + +module Self = +struct + type t = int + let compare = compare +end + +module Set = Set.Make(Self) +module Map = +struct + include CMap.Make(Self) + + type 'a map = 'a CMap.Make(Self).t + + type 'a _map = + | MEmpty + | MNode of 'a map * int * 'a * 'a map * int + + let map_prj : 'a map -> 'a _map = Obj.magic + + let rec find i s = match map_prj s with + | MEmpty -> raise Not_found + | MNode (l, k, v, r, h) -> + if i < k then find i l + else if i = k then v + else find i r +end + +module List = struct + let mem = List.memq + let assoc = List.assq + let mem_assoc = List.mem_assq + let remove_assoc = List.remove_assq +end + +let min (i : int) j = if i < j then i else j + +(** Utility function *) +let rec next from upto = + if from < upto then next (2 * from + 1) upto + else from + + +module PArray = +struct + + type 'a t = 'a data ref + and 'a data = + | Root of 'a option array + | DSet of int * 'a option * 'a t + + let empty n = ref (Root (Array.make n None)) + + let rec rerootk t k = match !t with + | Root _ -> k () + | DSet (i, v, t') -> + let next () = match !t' with + | Root a as n -> + let v' = Array.unsafe_get a i in + let () = Array.unsafe_set a i v in + let () = t := n in + let () = t' := DSet (i, v', t) in + k () + | DSet _ -> assert false + in + rerootk t' next + + let reroot t = rerootk t (fun () -> ()) + + let get t i = + let () = assert (0 <= i) in + match !t with + | Root a -> + if Array.length a <= i then None + else Array.unsafe_get a i + | DSet _ -> + let () = reroot t in + match !t with + | Root a -> + if Array.length a <= i then None + else Array.unsafe_get a i + | DSet _ -> assert false + + let set t i v = + let () = assert (0 <= i) in + let () = reroot t in + match !t with + | DSet _ -> assert false + | Root a as n -> + let len = Array.length a in + if i < len then + let old = Array.unsafe_get a i in + if old == v then t + else + let () = Array.unsafe_set a i v in + let res = ref n in + let () = t := DSet (i, old, res) in + res + else match v with + | None -> t (** Nothing to do! *) + | Some _ -> (** we must resize *) + let nlen = next len (succ i) in + let nlen = min nlen Sys.max_array_length in + let () = assert (i < nlen) in + let a' = Array.make nlen None in + let () = Array.blit a 0 a' 0 len in + let () = Array.unsafe_set a' i v in + let res = ref (Root a') in + let () = t := DSet (i, None, res) in + res + +end + +module PMap = +struct + + type key = int + + (** Invariants: + + 1. an empty map is always [Empty]. + 2. the set of the [Map] constructor remembers the present keys. + *) + type 'a t = Empty | Map of Set.t * 'a PArray.t + + let empty = Empty + + let is_empty = function + | Empty -> true + | Map _ -> false + + let singleton k x = + let len = next 19 (k + 1) in + let len = min Sys.max_array_length len in + let v = PArray.empty len in + let v = PArray.set v k (Some x) in + let s = Set.singleton k in + Map (s, v) + + let add k x = function + | Empty -> singleton k x + | Map (s, v) -> + let s = match PArray.get v k with + | None -> Set.add k s + | Some _ -> s + in + let v = PArray.set v k (Some x) in + Map (s, v) + + let remove k = function + | Empty -> Empty + | Map (s, v) -> + let s = Set.remove k s in + if Set.is_empty s then Empty + else + let v = PArray.set v k None in + Map (s, v) + + let mem k = function + | Empty -> false + | Map (_, v) -> + match PArray.get v k with + | None -> false + | Some _ -> true + + let find k = function + | Empty -> raise Not_found + | Map (_, v) -> + match PArray.get v k with + | None -> raise Not_found + | Some x -> x + + let iter f = function + | Empty -> () + | Map (s, v) -> + let iter k = match PArray.get v k with + | None -> () + | Some x -> f k x + in + Set.iter iter s + + let fold f m accu = match m with + | Empty -> accu + | Map (s, v) -> + let fold k accu = match PArray.get v k with + | None -> accu + | Some x -> f k x accu + in + Set.fold fold s accu + + let exists f m = match m with + | Empty -> false + | Map (s, v) -> + let exists k = match PArray.get v k with + | None -> false + | Some x -> f k x + in + Set.exists exists s + + let for_all f m = match m with + | Empty -> true + | Map (s, v) -> + let for_all k = match PArray.get v k with + | None -> true + | Some x -> f k x + in + Set.for_all for_all s + + let cast = function + | Empty -> Map.empty + | Map (s, v) -> + let bind k = match PArray.get v k with + | None -> assert false + | Some x -> x + in + Map.bind bind s + + let domain = function + | Empty -> Set.empty + | Map (s, _) -> s + +end diff --git a/lib/int.mli b/lib/int.mli new file mode 100644 index 00000000..c910bda6 --- /dev/null +++ b/lib/int.mli @@ -0,0 +1,79 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** A native integer module with usual utility functions. *) + +type t = int + +external equal : t -> t -> bool = "%eq" + +external compare : t -> t -> int = "caml_int_compare" + +val hash : t -> int + +module Set : Set.S with type elt = t +module Map : CMap.ExtS with type key = t and module Set := Set + +module List : sig + val mem : int -> int list -> bool + val assoc : int -> (int * 'a) list -> 'a + val mem_assoc : int -> (int * 'a) list -> bool + val remove_assoc : int -> (int * 'a) list -> (int * 'a) list +end + +module PArray : +sig + type 'a t + (** Persistent, auto-resizable arrays. The [get] and [set] functions never + fail whenever the index is between [0] and [Sys.max_array_length - 1]. *) + val empty : int -> 'a t + (** The empty array, with a given starting size. *) + val get : 'a t -> int -> 'a option + (** Get a value at the given index. Returns [None] if undefined. *) + val set : 'a t -> int -> 'a option -> 'a t + (** Set/unset a value at the given index. *) +end + +module PMap : +sig + type key = int + type 'a t + val empty : 'a t + val is_empty : 'a t -> bool + val mem : key -> 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val singleton : key -> 'a -> 'a t + val remove : key -> 'a t -> 'a t +(* val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t *) +(* val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int *) +(* val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool *) + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all : (key -> 'a -> bool) -> 'a t -> bool + val exists : (key -> 'a -> bool) -> 'a t -> bool +(* val filter : (key -> 'a -> bool) -> 'a t -> 'a t *) +(* val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t *) +(* val cardinal : 'a t -> int *) +(* val bindings : 'a t -> (key * 'a) list *) +(* val min_binding : 'a t -> key * 'a *) +(* val max_binding : 'a t -> key * 'a *) +(* val choose : 'a t -> key * 'a *) +(* val split : key -> 'a t -> 'a t * 'a option * 'a t *) + val find : key -> 'a t -> 'a +(* val map : ('a -> 'b) -> 'a t -> 'b t *) +(* val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t *) + val domain : 'a t -> Set.t + val cast : 'a t -> 'a Map.t +end +(** This is a (partial) implementation of a [Map] interface on integers, except + that it internally uses persistent arrays. This ensures O(1) accesses in + non-backtracking cases. It is thus better suited for zero-starting, + contiguous keys, or otherwise a lot of space will be empty. To keep track of + the present keys, a binary tree is also used, so that adding a key is + still logarithmic. It is therefore essential that most of the operations + are accesses and not add/removes. *) diff --git a/lib/lib.mllib b/lib/lib.mllib index db79b5c2..f3f6ad8f 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -1,31 +1,20 @@ -Xml_lexer -Xml_parser -Xml_utils -Pp_control -Pp -Compat -Flags -Segmenttree -Unicodetable -Util Errors Bigint -Hashcons Dyn +Segmenttree +Unicodetable +Unicode System -Envars -Gmap -Fset -Fmap -Tries -Gmapl +CThread +Spawn +Trie Profile Explore Predicate Rtree Heap -Option -Dnet -Store Unionfind -Hashtbl_alt +Genarg +Ephemeron +Future +RemoteCounter diff --git a/lib/loc.ml b/lib/loc.ml new file mode 100644 index 00000000..b62677d4 --- /dev/null +++ b/lib/loc.ml @@ -0,0 +1,79 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Locations management *) + + +type t = { + fname : string; (** filename *) + line_nb : int; (** start line number *) + bol_pos : int; (** position of the beginning of start line *) + line_nb_last : int; (** end line number *) + bol_pos_last : int; (** position of the beginning of end line *) + bp : int; (** start position *) + ep : int; (** end position *) +} + +let create fname line_nb bol_pos (bp, ep) = { + fname = fname; line_nb = line_nb; bol_pos = bol_pos; + line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; } + +let make_loc (bp, ep) = { + fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; + bp = bp; ep = ep; } + +let ghost = { + fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; + bp = 0; ep = 0; } + +let is_ghost loc = Pervasives.(=) loc ghost (** FIXME *) + +let merge loc1 loc2 = + if loc1.bp < loc2.bp then + if loc1.ep < loc2.ep then { + fname = loc1.fname; + line_nb = loc1.line_nb; + bol_pos = loc1.bol_pos; + line_nb_last = loc2.line_nb_last; + bol_pos_last = loc2.bol_pos_last; + bp = loc1.bp; ep = loc2.ep; } + else loc1 + else if loc2.ep < loc1.ep then { + fname = loc2.fname; + line_nb = loc2.line_nb; + bol_pos = loc2.bol_pos; + line_nb_last = loc1.line_nb_last; + bol_pos_last = loc1.bol_pos_last; + bp = loc2.bp; ep = loc1.ep; } + else loc2 + +let unloc loc = (loc.bp, loc.ep) + +let represent loc = (loc.fname, loc.line_nb, loc.bol_pos, loc.bp, loc.ep) + +let dummy_loc = ghost +let join_loc = merge + +(** Located type *) + +type 'a located = t * 'a +let located_fold_left f x (_,a) = f x a +let located_iter2 f (_,a) (_,b) = f a b +let down_located f (_,a) = f a + +(** Exceptions *) + +let location : t Exninfo.t = Exninfo.make () + +let add_loc e loc = Exninfo.add e location loc + +let get_loc e = Exninfo.get e location + +let raise loc e = + let info = Exninfo.add Exninfo.null location loc in + Exninfo.iraise (e, info) diff --git a/lib/loc.mli b/lib/loc.mli new file mode 100644 index 00000000..7a9a9ffd --- /dev/null +++ b/lib/loc.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** {5 Basic types} *) + +type t + +type 'a located = t * 'a +(** Embed a location in a type *) + +(** {5 Location manipulation} *) + +(** This is inherited from CAMPL4/5. *) + +val create : string -> int -> int -> (int * int) -> t +(** Create a location from a filename, a line number, a position of the + beginning of the line and a pair of start and end position *) + +val unloc : t -> int * int +(** Return the start and end position of a location *) + +val make_loc : int * int -> t +(** Make a location out of its start and end position *) + +val ghost : t +(** Dummy location *) + +val is_ghost : t -> bool +(** Test whether the location is meaningful *) + +val merge : t -> t -> t + +val represent : t -> (string * int * int * int * int) +(** Return the arguments given in [create] *) + +(** {5 Located exceptions} *) + +val add_loc : Exninfo.info -> t -> Exninfo.info +(** Adding location to an exception *) + +val get_loc : Exninfo.info -> t option +(** Retrieving the optional location of an exception *) + +val raise : t -> exn -> 'a +(** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *) + +(** {5 Location utilities} *) + +val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a +val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit + +val down_located : ('a -> 'b) -> 'a located -> 'b +(** Projects out a located object *) + +(** {5 Backward compatibility} *) + +val dummy_loc : t +(** Same as [ghost] *) + +val join_loc : t -> t -> t +(** Same as [merge] *) diff --git a/lib/monad.ml b/lib/monad.ml new file mode 100644 index 00000000..4a52684d --- /dev/null +++ b/lib/monad.ml @@ -0,0 +1,157 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + + +(** Combinators on monadic computations. *) + + +(** A definition of monads, each of the combinators is used in the + [Make] functor. *) +module type Def = sig + + type +'a t + val return : 'a -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>>) : unit t -> 'a t -> 'a t + val map : ('a -> 'b) -> 'a t -> 'b t + + (** The monadic laws must hold: + - [(x>>=f)>>=g] = [x>>=fun x' -> (f x'>>=g)] + - [return a >>= f] = [f a] + - [x>>=return] = [x] + + As well as the following identities: + - [x >> y] = [x >>= fun () -> y] + - [map f x] = [x >>= fun x' -> f x'] *) + +end + +module type ListS = sig + + type 'a t + + (** [List.map f l] maps [f] on the elements of [l] in left to right + order. *) + val map : ('a -> 'b t) -> 'a list -> 'b list t + + (** [List.map f l] maps [f] on the elements of [l] in right to left + order. *) + val map_right : ('a -> 'b t) -> 'a list -> 'b list t + + (** Like the regular [List.fold_right]. The monadic effects are + threaded right to left. + + Note: many monads behave poorly with right-to-left order. For + instance a failure monad would still have to traverse the + whole list in order to fail and failure needs to be propagated + through the rest of the list in binds which are now + spurious. It is also the worst case for substitution monads + (aka free monads), exposing the quadratic behaviour.*) + val fold_right : ('a -> 'b -> 'b t) -> 'a list -> 'b -> 'b t + + (** Like the regular [List.fold_left]. The monadic effects are + threaded left to right. It is tail-recursive if the [(>>=)] + operator calls its second argument in a tail position. *) + val fold_left : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t + + (** Like the regular [List.iter]. The monadic effects are threaded + left to right. It is tail-recurisve if the [>>] operator calls + its second argument in a tail position. *) + val iter : ('a -> unit t) -> 'a list -> unit t + + + (** {6 Two-list iterators} *) + + (** [fold_left2 r f s l1 l2] behaves like {!fold_left} but acts + simultaneously on two lists. Runs [r] (presumably an + exception-raising computation) if both lists do not have the + same length. *) + val fold_left2 : 'a t -> + ('a -> 'b -> 'c -> 'a t) -> 'a -> 'b list -> 'c list -> 'a t + +end + +module type S = sig + + include Def + + (** List combinators *) + module List : ListS with type 'a t := 'a t + +end + + +module Make (M:Def) : S with type +'a t = 'a M.t = struct + + include M + + module List = struct + + (* The combinators are loop-unrolled to spare a some monadic binds + (it is a common optimisation to treat the last of a list of + bind specially) and hopefully gain some efficiency using fewer + jump. *) + + let rec map f = function + | [] -> return [] + | [a] -> + M.map (fun a' -> [a']) (f a) + | a::b::l -> + f a >>= fun a' -> + f b >>= fun b' -> + M.map (fun l' -> a'::b'::l') (map f l) + + let rec map_right f = function + | [] -> return [] + | [a] -> + M.map (fun a' -> [a']) (f a) + | a::b::l -> + map f l >>= fun l' -> + f b >>= fun b' -> + M.map (fun a' -> a'::b'::l') (f a) + + let rec fold_right f l x = + match l with + | [] -> return x + | [a] -> f a x + | a::b::l -> + fold_right f l x >>= fun acc -> + f b acc >>= fun acc -> + f a acc + + let rec fold_left f x = function + | [] -> return x + | [a] -> f x a + | a::b::l -> + f x a >>= fun x' -> + f x' b >>= fun x'' -> + fold_left f x'' l + + let rec iter f = function + | [] -> return () + | [a] -> f a + | a::b::l -> f a >> f b >> iter f l + + + + let rec fold_left2 r f x l1 l2 = + match l1,l2 with + | [] , [] -> return x + | [a] , [b] -> f x a b + | a1::a2::l1 , b1::b2::l2 -> + f x a1 b1 >>= fun x' -> + f x' a2 b2 >>= fun x'' -> + fold_left2 r f x'' l1 l2 + | _ , _ -> r + + end + +end + + + diff --git a/lib/monad.mli b/lib/monad.mli new file mode 100644 index 00000000..c8655efa --- /dev/null +++ b/lib/monad.mli @@ -0,0 +1,90 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + + +(** Combinators on monadic computations. *) + + +(** A definition of monads, each of the combinators is used in the + [Make] functor. *) +module type Def = sig + + type +'a t + val return : 'a -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>>) : unit t -> 'a t -> 'a t + val map : ('a -> 'b) -> 'a t -> 'b t + +(** The monadic laws must hold: + - [(x>>=f)>>=g] = [x>>=fun x' -> (f x'>>=g)] + - [return a >>= f] = [f a] + - [x>>=return] = [x] + + As well as the following identities: + - [x >> y] = [x >>= fun () -> y] + - [map f x] = [x >>= fun x' -> f x'] *) + +end + + +(** List combinators *) +module type ListS = sig + + type 'a t + + (** [List.map f l] maps [f] on the elements of [l] in left to right + order. *) + val map : ('a -> 'b t) -> 'a list -> 'b list t + + (** [List.map f l] maps [f] on the elements of [l] in right to left + order. *) + val map_right : ('a -> 'b t) -> 'a list -> 'b list t + + (** Like the regular [List.fold_right]. The monadic effects are + threaded right to left. + + Note: many monads behave poorly with right-to-left order. For + instance a failure monad would still have to traverse the + whole list in order to fail and failure needs to be propagated + through the rest of the list in binds which are now + spurious. It is also the worst case for substitution monads + (aka free monads), exposing the quadratic behaviour.*) + val fold_right : ('a -> 'b -> 'b t) -> 'a list -> 'b -> 'b t + + (** Like the regular [List.fold_left]. The monadic effects are + threaded left to right. It is tail-recursive if the [(>>=)] + operator calls its second argument in a tail position. *) + val fold_left : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t + + (** Like the regular [List.iter]. The monadic effects are threaded + left to right. It is tail-recurisve if the [>>] operator calls + its second argument in a tail position. *) + val iter : ('a -> unit t) -> 'a list -> unit t + + + (** {6 Two-list iterators} *) + + (** [fold_left2 r f s l1 l2] behaves like {!fold_left} but acts + simultaneously on two lists. Runs [r] (presumably an + exception-raising computation) if both lists do not have the + same length. *) + val fold_left2 : 'a t -> + ('a -> 'b -> 'c -> 'a t) -> 'a -> 'b list -> 'c list -> 'a t + +end + +module type S = sig + + include Def + + module List : ListS with type 'a t := 'a t + +end + +(** Expands the monadic definition to extra combinators. *) +module Make (M:Def) : S with type +'a t = 'a M.t diff --git a/lib/option.ml b/lib/option.ml index d6df7063..9ea1a769 100644 --- a/lib/option.ml +++ b/lib/option.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,6 +19,26 @@ let has_some = function | None -> false | _ -> true +let is_empty = function +| None -> true +| Some _ -> false + +(** Lifting equality onto option types. *) +let equal f x y = match x, y with +| None, None -> true +| Some x, Some y -> f x y +| _, _ -> false + +let compare f x y = match x, y with +| None, None -> 0 +| Some x, Some y -> f x y +| None, Some _ -> -1 +| Some _, None -> 1 + +let hash f = function +| None -> 0 +| Some x -> f x + exception IsNone (** [get x] returns [y] where [x] is [Some y]. It raises IsNone @@ -44,6 +64,14 @@ let flatten = function | _ -> None +(** [append x y] is the first element of the concatenation of [x] and + [y] seen as lists. *) +let append o1 o2 = + match o1 with + | Some _ -> o1 + | None -> o2 + + (** {6 "Iterators"} ***) (** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing @@ -153,21 +181,11 @@ module List = let rec flatten = function | x::l -> cons x (flatten l) | [] -> [] -end - + let rec find f = function + |[] -> None + |h :: t -> match f h with + |None -> find f t + |x -> x -(** {6 Miscelaneous Primitives} *) - -module Misc = - struct - (** [Misc.compare f x y] lifts the equality predicate [f] to - option types. That is, if both [x] and [y] are [None] then - it returns [true], if they are bothe [Some _] then - [f] is called. Otherwise it returns [false]. *) - let compare f x y = - match x,y with - | None, None -> true - | Some z, Some w -> f z w - | _,_ -> false end diff --git a/lib/option.mli b/lib/option.mli index 121d6500..d9ad0e11 100644 --- a/lib/option.mli +++ b/lib/option.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,11 +13,26 @@ they actually are similar considering ['a option] as a type of lists with at most one element. *) +exception IsNone + (** [has_some x] is [true] if [x] is of the form [Some y] and [false] otherwise. *) val has_some : 'a option -> bool -exception IsNone +(** Negation of [has_some] *) +val is_empty : 'a option -> bool + +(** [equal f x y] lifts the equality predicate [f] to + option types. That is, if both [x] and [y] are [None] then + it returns [true], if they are both [Some _] then + [f] is called. Otherwise it returns [false]. *) +val equal : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool + +(** Same as [equal], but with comparison. *) +val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int + +(** Lift a hash to option types. *) +val hash : ('a -> int) -> 'a option -> int (** [get x] returns [y] where [x] is [Some y]. It raises IsNone if [x] equals [None]. *) @@ -32,6 +47,12 @@ val init : bool -> 'a -> 'a option (** [flatten x] is [Some y] if [x] is [Some (Some y)] and [None] otherwise. *) val flatten : 'a option option -> 'a option +(** [append x y] is the first element of the concatenation of [x] and + [y] seen as lists. In other words, [append (Some a) y] is [Some + a], [append None (Some b)] is [Some b], and [append None None] is + [None]. *) +val append : 'a option -> 'a option -> 'a option + (** {6 "Iterators"} ***) @@ -67,7 +88,7 @@ val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b (** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option -(** [cata e f x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) +(** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) val cata : ('a -> 'b) -> 'b -> 'a option -> 'b (** {6 More Specific Operations} ***) @@ -100,16 +121,6 @@ module List : sig (** [List.flatten l] is the list of all the [y]s such that [l] contains [Some y] (in the same order). *) val flatten : 'a option list -> 'a list -end - -(** {6 Miscelaneous Primitives} *) - -module Misc : sig - (** [Misc.compare f x y] lifts the equality predicate [f] to - option types. That is, if both [x] and [y] are [None] then - it returns [true], if they are bothe [Some _] then - [f] is called. Otherwise it returns [false]. *) - val compare : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool + val find : ('a -> 'b option) -> 'a list -> 'b option end - diff --git a/lib/pp.ml b/lib/pp.ml new file mode 100644 index 00000000..234d2344 --- /dev/null +++ b/lib/pp.ml @@ -0,0 +1,591 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module Glue : sig + + (* A left associative glue implements efficient glue operator + when used as left associative. If glue is denoted ++ then + + a ++ b ++ c ++ d = ((a ++ b) ++ c) ++ d = [d] @ ([c] @ ([b] @ [a])) + + I.e. if the short list is the second argument + *) + type 'a t + + val atom : 'a -> 'a t + val glue : 'a t -> 'a t -> 'a t + val empty : 'a t + val is_empty : 'a t -> bool + val iter : ('a -> unit) -> 'a t -> unit + val map : ('a -> 'b) -> 'a t -> 'b t + +end = struct + + type 'a t = 'a list + + let atom x = [x] + let glue x y = y @ x + let empty = [] + let is_empty x = x = [] + + let iter f g = List.iter f (List.rev g) + let map = List.map +end + +module Tag : +sig + type t + type 'a key + val create : string -> 'a key + val inj : 'a -> 'a key -> t + val prj : t -> 'a key -> 'a option +end = +struct + (** See module {Dyn} for more details. *) + + type t = int * Obj.t + + type 'a key = int + + let dyntab = ref (Int.Map.empty : string Int.Map.t) + + let create (s : string) = + let hash = Hashtbl.hash s in + let () = assert (not (Int.Map.mem hash !dyntab)) in + let () = dyntab := Int.Map.add hash s !dyntab in + hash + + let inj x h = (h, Obj.repr x) + + let prj (nh, rv) h = + if Int.equal h nh then Some (Obj.magic rv) + else None + +end + +open Pp_control + +(* This should not be used outside of this file. Use + Flags.print_emacs instead. This one is updated when reading + command line options. This was the only way to make [Pp] depend on + an option without creating a circularity: [Flags] -> [Util] -> + [Pp] -> [Flags] *) +let print_emacs = ref false + +(* The different kinds of blocks are: + \begin{description} + \item[hbox:] Horizontal block no line breaking; + \item[vbox:] Vertical block each break leads to a new line; + \item[hvbox:] Horizontal-vertical block: same as vbox, except if + this block is small enough to fit on a single line + \item[hovbox:] Horizontal or Vertical block: breaks lead to new line + only when necessary to print the content of the block + \item[tbox:] Tabulation block: go to tabulation marks and no line breaking + (except if no mark yet on the reste of the line) + \end{description} + *) + +let comments = ref [] + +let rec split_com comacc acc pos = function + [] -> comments := List.rev acc; comacc + | ((b,e),c as com)::coms -> + (* Take all comments that terminates before pos, or begin exactly + at pos (used to print comments attached after an expression) *) + if e<=pos || pos=b then split_com (c::comacc) acc pos coms + else split_com comacc (com::acc) pos coms + + +type block_type = + | Pp_hbox of int + | Pp_vbox of int + | Pp_hvbox of int + | Pp_hovbox of int + | Pp_tbox + +type str_token = +| Str_def of string +| Str_len of string * int (** provided length *) + +type 'a ppcmd_token = + | Ppcmd_print of 'a + | Ppcmd_box of block_type * ('a ppcmd_token Glue.t) + | Ppcmd_print_break of int * int + | Ppcmd_set_tab + | Ppcmd_print_tbreak of int * int + | Ppcmd_white_space of int + | Ppcmd_force_newline + | Ppcmd_print_if_broken + | Ppcmd_open_box of block_type + | Ppcmd_close_box + | Ppcmd_close_tbox + | Ppcmd_comment of int + | Ppcmd_open_tag of Tag.t + | Ppcmd_close_tag + +type 'a ppdir_token = + | Ppdir_ppcmds of 'a ppcmd_token Glue.t + | Ppdir_print_newline + | Ppdir_print_flush + +type ppcmd = str_token ppcmd_token + +type std_ppcmds = ppcmd Glue.t + +type 'a ppdirs = 'a ppdir_token Glue.t + +let (++) = Glue.glue + +let app = Glue.glue + +let is_empty g = Glue.is_empty g + +let rewrite f p = + let strtoken = function + | Str_len (s, n) -> + let s' = f s in + Str_len (s', String.length s') + | Str_def s -> + Str_def (f s) + in + let rec ppcmd_token = function + | Ppcmd_print x -> Ppcmd_print (strtoken x) + | Ppcmd_box (bt, g) -> Ppcmd_box (bt, Glue.map ppcmd_token g) + | p -> p + in + Glue.map ppcmd_token p + +(* Compute length of an UTF-8 encoded string + Rem 1 : utf8_length <= String.length (equal if pure ascii) + Rem 2 : if used for an iso8859_1 encoded string, the result is + wrong in very rare cases. Such a wrong case corresponds to any + sequence of a character in range 192..253 immediately followed by a + character in range 128..191 (typical case in french is "déçu" which + is counted 3 instead of 4); then no real harm to use always + utf8_length even if using an iso8859_1 encoding *) + +let utf8_length s = + let len = String.length s + and cnt = ref 0 + and nc = ref 0 + and p = ref 0 in + while !p < len do + begin + match s.[!p] with + | '\000'..'\127' -> nc := 0 (* ascii char *) + | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *) + | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) + | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) + | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) + | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) + | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) + | '\254'..'\255' -> nc := 0 (* invalid byte *) + end ; + incr p ; + while !p < len && !nc > 0 do + match s.[!p] with + | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc + | _ (* not a continuation byte *) -> nc := 0 + done ; + incr cnt + done ; + !cnt + +(* formatting commands *) +let str s = Glue.atom(Ppcmd_print (Str_def s)) +let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i))) +let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b)) +let tbrk (a,b) = Glue.atom(Ppcmd_print_tbreak (a,b)) +let tab () = Glue.atom(Ppcmd_set_tab) +let fnl () = Glue.atom(Ppcmd_force_newline) +let pifb () = Glue.atom(Ppcmd_print_if_broken) +let ws n = Glue.atom(Ppcmd_white_space n) +let comment n = Glue.atom(Ppcmd_comment n) + +(* derived commands *) +let mt () = Glue.empty +let spc () = Glue.atom(Ppcmd_print_break (1,0)) +let cut () = Glue.atom(Ppcmd_print_break (0,0)) +let align () = Glue.atom(Ppcmd_print_break (0,0)) +let int n = str (string_of_int n) +let real r = str (string_of_float r) +let bool b = str (string_of_bool b) +let strbrk s = + let rec aux p n = + if n < String.length s then + if s.[n] = ' ' then + if p = n then spc() :: aux (n+1) (n+1) + else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1) + else aux p (n + 1) + else if p = n then [] else [str (String.sub s p (n-p))] + in List.fold_left (++) Glue.empty (aux 0 0) + +let ismt = is_empty + +(* boxing commands *) +let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s)) +let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s)) +let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s)) +let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s)) +let t s = Glue.atom(Ppcmd_box(Pp_tbox,s)) + +(* Opening and closing of boxes *) +let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n)) +let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n)) +let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n)) +let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n)) +let tb () = Glue.atom(Ppcmd_open_box Pp_tbox) +let close () = Glue.atom(Ppcmd_close_box) +let tclose () = Glue.atom(Ppcmd_close_tbox) + +(* Opening and closed of tags *) +let open_tag t = Glue.atom(Ppcmd_open_tag t) +let close_tag () = Glue.atom(Ppcmd_close_tag) +let tag t s = open_tag t ++ s ++ close_tag () +let eval_ppcmds l = l + +(* In new syntax only double quote char is escaped by repeating it *) +let escape_string s = + let rec escape_at s i = + if i<0 then s + else if s.[i] == '"' then + let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in + escape_at s' (i-1) + else escape_at s (i-1) in + escape_at s (String.length s - 1) + +let qstring s = str ("\""^escape_string s^"\"") +let qs = qstring +let quote s = h 0 (str "\"" ++ s ++ str "\"") + +(* This flag tells if the last printed comment ends with a newline, to + avoid empty lines *) +let com_eol = ref false + +let com_brk ft = com_eol := false +let com_if ft f = + if !com_eol then (com_eol := false; Format.pp_force_newline ft ()) + else Lazy.force f + +let rec pr_com ft s = + let (s1,os) = + try + let n = String.index s '\n' in + String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1)) + with Not_found -> s,None in + com_if ft (Lazy.lazy_from_val()); +(* let s1 = + if String.length s1 <> 0 && s1.[0] = ' ' then + (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1)) + else s1 in*) + Format.pp_print_as ft (utf8_length s1) s1; + match os with + Some s2 -> + if Int.equal (String.length s2) 0 then (com_eol := true) + else + (Format.pp_force_newline ft (); pr_com ft s2) + | None -> () + +type tag_handler = Tag.t -> Format.tag + +(* pretty printing functions *) +let pp_dirs ?pp_tag ft = + let pp_open_box = function + | Pp_hbox n -> Format.pp_open_hbox ft () + | Pp_vbox n -> Format.pp_open_vbox ft n + | Pp_hvbox n -> Format.pp_open_hvbox ft n + | Pp_hovbox n -> Format.pp_open_hovbox ft n + | Pp_tbox -> Format.pp_open_tbox ft () + in + let rec pp_cmd = function + | Ppcmd_print tok -> + begin match tok with + | Str_def s -> + let n = utf8_length s in + com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s + | Str_len (s, n) -> + com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s + end + | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) + com_if ft (Lazy.lazy_from_val()); + pp_open_box bty ; + if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; + Format.pp_close_box ft () + | Ppcmd_open_box bty -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty + | Ppcmd_close_box -> Format.pp_close_box ft () + | Ppcmd_close_tbox -> Format.pp_close_tbox ft () + | Ppcmd_white_space n -> + com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0)) + | Ppcmd_print_break(m,n) -> + com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n)) + | Ppcmd_set_tab -> Format.pp_set_tab ft () + | Ppcmd_print_tbreak(m,n) -> + com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n)) + | Ppcmd_force_newline -> + com_brk ft; Format.pp_force_newline ft () + | Ppcmd_print_if_broken -> + com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ())) + | Ppcmd_comment i -> + let coms = split_com [] [] i !comments in +(* Format.pp_open_hvbox ft 0;*) + List.iter (pr_com ft) coms(*; + Format.pp_close_box ft ()*) + | Ppcmd_open_tag tag -> + begin match pp_tag with + | None -> () + | Some f -> Format.pp_open_tag ft (f tag) + end + | Ppcmd_close_tag -> + begin match pp_tag with + | None -> () + | Some _ -> Format.pp_close_tag ft () + end + in + let pp_dir = function + | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream + | Ppdir_print_newline -> + com_brk ft; Format.pp_print_newline ft () + | Ppdir_print_flush -> Format.pp_print_flush ft () + in + fun (dirstream : _ ppdirs) -> + try + Glue.iter pp_dir dirstream; com_brk ft + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + let () = Format.pp_print_flush ft () in + Exninfo.iraise reraise + + + +(* pretty print on stdout and stderr *) + +(* Special chars for emacs, to detect warnings inside goal output *) +let emacs_quote_start = String.make 1 (Char.chr 254) +let emacs_quote_end = String.make 1 (Char.chr 255) + +let emacs_quote_info_start = "<infomsg>" +let emacs_quote_info_end = "</infomsg>" + +let emacs_quote g = + if !print_emacs then str emacs_quote_start ++ hov 0 g ++ str emacs_quote_end + else hov 0 g + +let emacs_quote_info g = + if !print_emacs then str emacs_quote_info_start++fnl() ++ hov 0 g ++ str emacs_quote_info_end + else hov 0 g + + +(* pretty printing functions WITHOUT FLUSH *) +let pp_with ?pp_tag ft strm = + pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm)) + +let ppnl_with ft strm = + pp_dirs ft (Glue.atom (Ppdir_ppcmds (strm ++ fnl ()))) + +let pp_flush_with ft = Format.pp_print_flush ft + +(* pretty printing functions WITH FLUSH *) +let msg_with ft strm = + pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) + +let msgnl_with ft strm = + pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_newline)) + +(* pretty printing functions WITHOUT FLUSH *) +let pp x = pp_with !std_ft x +let ppnl x = ppnl_with !std_ft x +let pperr x = pp_with !err_ft x +let pperrnl x = ppnl_with !err_ft x +let message s = ppnl (str s) +let pp_flush x = Format.pp_print_flush !std_ft x +let pperr_flush x = Format.pp_print_flush !err_ft x +let flush_all () = + flush stderr; flush stdout; pp_flush (); pperr_flush () + +(* pretty printing functions WITH FLUSH *) +let msg x = msg_with !std_ft x +let msgnl x = msgnl_with !std_ft x +let msgerr x = msg_with !err_ft x +let msgerrnl x = msgnl_with !err_ft x + +(* Logging management *) + +type message_level = Feedback.message_level = + | Debug of string + | Info + | Notice + | Warning + | Error + +type message = Feedback.message = { + message_level : message_level; + message_content : string; +} + +let of_message = Feedback.of_message +let to_message = Feedback.to_message +let is_message = Feedback.is_message + +type logger = message_level -> std_ppcmds -> unit + +let make_body info s = + emacs_quote (hov 0 (info ++ spc () ++ s)) + +let debugbody strm = hov 0 (str "Debug:" ++ spc () ++ strm) +let warnbody strm = make_body (str "Warning:") strm +let errorbody strm = make_body (str "Error:") strm +let infobody strm = emacs_quote_info strm + +let std_logger ~id:_ level msg = match level with +| Debug _ -> msgnl (debugbody msg) +| Info -> msgnl (hov 0 msg) +| Notice -> msgnl msg +| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody msg)) () +| Error -> msgnl_with !err_ft (errorbody msg) + +let emacs_logger ~id:_ level mesg = match level with +| Debug _ -> msgnl (debugbody mesg) +| Info -> msgnl (infobody mesg) +| Notice -> msgnl mesg +| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody mesg)) () +| Error -> msgnl_with !err_ft (errorbody mesg) + +let logger = ref std_logger + +let make_pp_emacs() = print_emacs:=true; logger:=emacs_logger +let make_pp_nonemacs() = print_emacs:=false; logger := std_logger + + +let feedback_id = ref (Feedback.Edit 0) +let feedback_route = ref Feedback.default_route + +(* If mixing some output and a goal display, please use msg_warning, + so that interfaces (proofgeneral for example) can easily dispatch + them to different windows. *) + +let msg_info x = !logger ~id:!feedback_id Info x +let msg_notice x = !logger ~id:!feedback_id Notice x +let msg_warning x = !logger ~id:!feedback_id Warning x +let msg_error x = !logger ~id:!feedback_id Error x +let msg_debug x = !logger ~id:!feedback_id (Debug "_") x + +let set_logger l = logger := (fun ~id:_ lvl msg -> l lvl msg) + +let std_logger lvl msg = std_logger ~id:!feedback_id lvl msg + +(** Feedback *) + +let feeder = ref ignore +let set_id_for_feedback ?(route=Feedback.default_route) i = + feedback_id := i; feedback_route := route +let feedback ?state_id ?edit_id ?route what = + !feeder { + Feedback.contents = what; + Feedback.route = Option.default !feedback_route route; + Feedback.id = + match state_id, edit_id with + | Some id, _ -> Feedback.State id + | None, Some eid -> Feedback.Edit eid + | None, None -> !feedback_id; + } +let set_feeder f = feeder := f +let get_id_for_feedback () = !feedback_id, !feedback_route + +(** Utility *) + +let string_of_ppcmds c = + msg_with Format.str_formatter c; + Format.flush_str_formatter () + +let log_via_feedback () = logger := (fun ~id lvl msg -> + !feeder { + Feedback.contents = Feedback.Message { + message_level = lvl; + message_content = string_of_ppcmds msg }; + Feedback.route = !feedback_route; + Feedback.id = id }) + +(* Copy paste from Util *) + +let pr_comma () = str "," ++ spc () +let pr_semicolon () = str ";" ++ spc () +let pr_bar () = str "|" ++ spc () +let pr_arg pr x = spc () ++ pr x +let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x +let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x + +let pr_nth n = + int n ++ str (match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th") + +(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) + +let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Glue.empty l + +(* unlike all other functions below, [prlist] works lazily. + if a strict behavior is needed, use [prlist_strict] instead. + evaluation is done from left to right. *) + +let prlist_sep_lastsep no_empty sep lastsep elem = + let rec start = function + |[] -> mt () + |[e] -> elem e + |h::t -> let e = elem h in + if no_empty && ismt e then start t else + let rec aux = function + |[] -> mt () + |h::t -> + let e = elem h and r = aux t in + if no_empty && ismt e then r else + if ismt r + then let s = lastsep () in s ++ e + else let s = sep () in s ++ e ++ r + in let r = aux t in e ++ r + in start + +let prlist_strict pr l = prlist_sep_lastsep true mt mt pr l +(* [prlist_with_sep sep pr [a ; ... ; c]] outputs + [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) +let prlist_with_sep sep pr l = prlist_sep_lastsep false sep sep pr l +(* Print sequence of objects separated by space (unless an element is empty) *) +let pr_sequence pr l = prlist_sep_lastsep true spc spc pr l +(* [pr_enum pr [a ; b ; ... ; c]] outputs + [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *) +let pr_enum pr l = prlist_sep_lastsep true pr_comma (fun () -> str " and" ++ spc ()) pr l + +let pr_vertical_list pr = function + | [] -> str "none" ++ fnl () + | l -> fnl () ++ str " " ++ hov 0 (prlist_with_sep fnl pr l) ++ fnl () + +(* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs + [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *) + +let prvecti_with_sep sep elem v = + let rec pr i = + if Int.equal i 0 then + elem 0 v.(0) + else + let r = pr (i-1) and s = sep () and e = elem i v.(i) in + r ++ s ++ e + in + let n = Array.length v in + if Int.equal n 0 then mt () else pr (n - 1) + +(* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *) + +let prvecti elem v = prvecti_with_sep mt elem v + +(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs + [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) + +let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v + +(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *) + +let prvect elem v = prvect_with_sep mt elem v + +let surround p = hov 1 (str"(" ++ p ++ str")") diff --git a/lib/pp.ml4 b/lib/pp.ml4 deleted file mode 100644 index f13a3d16..00000000 --- a/lib/pp.ml4 +++ /dev/null @@ -1,351 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Pp_control - -(* This should not be used outside of this file. Use - Flags.print_emacs instead. This one is updated when reading - command line options. This was the only way to make [Pp] depend on - an option without creating a circularity: [Flags. -> [Util] -> - [Pp] -> [Flags. *) -let print_emacs = ref false -let make_pp_emacs() = print_emacs:=true -let make_pp_nonemacs() = print_emacs:=false - -(* The different kinds of blocks are: - \begin{description} - \item[hbox:] Horizontal block no line breaking; - \item[vbox:] Vertical block each break leads to a new line; - \item[hvbox:] Horizontal-vertical block: same as vbox, except if - this block is small enough to fit on a single line - \item[hovbox:] Horizontal or Vertical block: breaks lead to new line - only when necessary to print the content of the block - \item[tbox:] Tabulation block: go to tabulation marks and no line breaking - (except if no mark yet on the reste of the line) - \end{description} - *) - -let comments = ref [] - -let rec split_com comacc acc pos = function - [] -> comments := List.rev acc; comacc - | ((b,e),c as com)::coms -> - (* Take all comments that terminates before pos, or begin exactly - at pos (used to print comments attached after an expression) *) - if e<=pos || pos=b then split_com (c::comacc) acc pos coms - else split_com comacc (com::acc) pos coms - - -type block_type = - | Pp_hbox of int - | Pp_vbox of int - | Pp_hvbox of int - | Pp_hovbox of int - | Pp_tbox - -type 'a ppcmd_token = - | Ppcmd_print of 'a - | Ppcmd_box of block_type * ('a ppcmd_token Stream.t) - | Ppcmd_print_break of int * int - | Ppcmd_set_tab - | Ppcmd_print_tbreak of int * int - | Ppcmd_white_space of int - | Ppcmd_force_newline - | Ppcmd_print_if_broken - | Ppcmd_open_box of block_type - | Ppcmd_close_box - | Ppcmd_close_tbox - | Ppcmd_comment of int - -type 'a ppdir_token = - | Ppdir_ppcmds of 'a ppcmd_token Stream.t - | Ppdir_print_newline - | Ppdir_print_flush - -type ppcmd = (int*string) ppcmd_token - -type std_ppcmds = ppcmd Stream.t - -type 'a ppdirs = 'a ppdir_token Stream.t - -(* Compute length of an UTF-8 encoded string - Rem 1 : utf8_length <= String.length (equal if pure ascii) - Rem 2 : if used for an iso8859_1 encoded string, the result is - wrong in very rare cases. Such a wrong case corresponds to any - sequence of a character in range 192..253 immediately followed by a - character in range 128..191 (typical case in french is "déçu" which - is counted 3 instead of 4); then no real harm to use always - utf8_length even if using an iso8859_1 encoding *) - -let utf8_length s = - let len = String.length s - and cnt = ref 0 - and nc = ref 0 - and p = ref 0 in - while !p < len do - begin - match s.[!p] with - | '\000'..'\127' -> nc := 0 (* ascii char *) - | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *) - | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) - | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) - | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) - | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) - | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) - | '\254'..'\255' -> nc := 0 (* invalid byte *) - end ; - incr p ; - while !p < len && !nc > 0 do - match s.[!p] with - | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc - | _ (* not a continuation byte *) -> nc := 0 - done ; - incr cnt - done ; - !cnt - -(* formatting commands *) -let str s = [< 'Ppcmd_print (utf8_length s,s) >] -let stras (i,s) = [< 'Ppcmd_print (i,s) >] -let brk (a,b) = [< 'Ppcmd_print_break (a,b) >] -let tbrk (a,b) = [< 'Ppcmd_print_tbreak (a,b) >] -let tab () = [< 'Ppcmd_set_tab >] -let fnl () = [< 'Ppcmd_force_newline >] -let pifb () = [< 'Ppcmd_print_if_broken >] -let ws n = [< 'Ppcmd_white_space n >] -let comment n = [< ' Ppcmd_comment n >] - -(* derived commands *) -let mt () = [< >] -let spc () = [< 'Ppcmd_print_break (1,0) >] -let cut () = [< 'Ppcmd_print_break (0,0) >] -let align () = [< 'Ppcmd_print_break (0,0) >] -let int n = str (string_of_int n) -let real r = str (string_of_float r) -let bool b = str (string_of_bool b) -let strbrk s = - let rec aux p n = - if n < String.length s then - if s.[n] = ' ' then - if p=n then [< spc (); aux (n+1) (n+1) >] - else [< str (String.sub s p (n-p)); spc (); aux (n+1) (n+1) >] - else aux p (n+1) - else if p=n then [< >] else [< str (String.sub s p (n-p)) >] - in aux 0 0 - -let ismt s = try let _ = Stream.empty s in true with Stream.Failure -> false - -(* boxing commands *) -let h n s = [< 'Ppcmd_box(Pp_hbox n,s) >] -let v n s = [< 'Ppcmd_box(Pp_vbox n,s) >] -let hv n s = [< 'Ppcmd_box(Pp_hvbox n,s) >] -let hov n s = [< 'Ppcmd_box(Pp_hovbox n,s) >] -let t s = [< 'Ppcmd_box(Pp_tbox,s) >] - -(* Opening and closing of boxes *) -let hb n = [< 'Ppcmd_open_box(Pp_hbox n) >] -let vb n = [< 'Ppcmd_open_box(Pp_vbox n) >] -let hvb n = [< 'Ppcmd_open_box(Pp_hvbox n) >] -let hovb n = [< 'Ppcmd_open_box(Pp_hovbox n) >] -let tb () = [< 'Ppcmd_open_box Pp_tbox >] -let close () = [< 'Ppcmd_close_box >] -let tclose () = [< 'Ppcmd_close_tbox >] - -let (++) = Stream.iapp - -let rec eval_ppcmds l = - let rec aux l = - try - let a = match Stream.next l with - | Ppcmd_box (b,s) -> Ppcmd_box (b,eval_ppcmds s) - | a -> a in - let rest = aux l in - a :: rest - with Stream.Failure -> [] in - Stream.of_list (aux l) - -(* In new syntax only double quote char is escaped by repeating it *) -let rec escape_string s = - let rec escape_at s i = - if i<0 then s - else if s.[i] == '"' then - let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in - escape_at s' (i-1) - else escape_at s (i-1) in - escape_at s (String.length s - 1) - -let qstring s = str ("\""^escape_string s^"\"") -let qs = qstring -let quote s = h 0 (str "\"" ++ s ++ str "\"") - -let rec xmlescape ppcmd = - let rec escape what withwhat (len, str) = - try - let pos = String.index str what in - let (tlen, tail) = - escape what withwhat ((len - pos - 1), - (String.sub str (pos + 1) (len - pos - 1))) - in - (pos + tlen + String.length withwhat, String.sub str 0 pos ^ withwhat ^ tail) - with Not_found -> (len, str) - in - match ppcmd with - | Ppcmd_print (len, str) -> - Ppcmd_print (escape '"' """ - (escape '<' "<" (escape '&' "&" (len, str)))) - (* In XML we always print whole content so we can npeek the whole stream *) - | Ppcmd_box (x, str) -> Ppcmd_box (x, Stream.of_list - (List.map xmlescape (Stream.npeek max_int str))) - | x -> x - - -(* This flag tells if the last printed comment ends with a newline, to - avoid empty lines *) -let com_eol = ref false - -let com_brk ft = com_eol := false -let com_if ft f = - if !com_eol then (com_eol := false; Format.pp_force_newline ft ()) - else Lazy.force f - -let rec pr_com ft s = - let (s1,os) = - try - let n = String.index s '\n' in - String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1)) - with Not_found -> s,None in - com_if ft (Lazy.lazy_from_val()); -(* let s1 = - if String.length s1 <> 0 && s1.[0] = ' ' then - (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1)) - else s1 in*) - Format.pp_print_as ft (utf8_length s1) s1; - match os with - Some s2 -> - if String.length s2 = 0 then (com_eol := true) - else - (Format.pp_force_newline ft (); pr_com ft s2) - | None -> () - -(* pretty printing functions *) -let pp_dirs ft = - let pp_open_box = function - | Pp_hbox n -> Format.pp_open_hbox ft () - | Pp_vbox n -> Format.pp_open_vbox ft n - | Pp_hvbox n -> Format.pp_open_hvbox ft n - | Pp_hovbox n -> Format.pp_open_hovbox ft n - | Pp_tbox -> Format.pp_open_tbox ft () - in - let rec pp_cmd = function - | Ppcmd_print(n,s) -> - com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s - | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - com_if ft (Lazy.lazy_from_val()); - pp_open_box bty ; - if not (Format.over_max_boxes ()) then Stream.iter pp_cmd ss; - Format.pp_close_box ft () - | Ppcmd_open_box bty -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty - | Ppcmd_close_box -> Format.pp_close_box ft () - | Ppcmd_close_tbox -> Format.pp_close_tbox ft () - | Ppcmd_white_space n -> - com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0)) - | Ppcmd_print_break(m,n) -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n)) - | Ppcmd_set_tab -> Format.pp_set_tab ft () - | Ppcmd_print_tbreak(m,n) -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n)) - | Ppcmd_force_newline -> - com_brk ft; Format.pp_force_newline ft () - | Ppcmd_print_if_broken -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ())) - | Ppcmd_comment i -> - let coms = split_com [] [] i !comments in -(* Format.pp_open_hvbox ft 0;*) - List.iter (pr_com ft) coms(*; - Format.pp_close_box ft ()*) - in - let pp_dir = function - | Ppdir_ppcmds cmdstream -> Stream.iter pp_cmd cmdstream - | Ppdir_print_newline -> - com_brk ft; Format.pp_print_newline ft () - | Ppdir_print_flush -> Format.pp_print_flush ft () - in - fun dirstream -> - try - Stream.iter pp_dir dirstream; com_brk ft - with - | reraise -> Format.pp_print_flush ft () ; raise reraise - - -(* pretty print on stdout and stderr *) - -(* Special chars for emacs, to detect warnings inside goal output *) -let emacs_quote_start = String.make 1 (Char.chr 254) -let emacs_quote_end = String.make 1 (Char.chr 255) - -let emacs_quote strm = - if !print_emacs then - [< str emacs_quote_start; hov 0 strm; str emacs_quote_end >] - else hov 0 strm - -let warnbody strm = emacs_quote (str "Warning: " ++ strm) - -(* pretty printing functions WITHOUT FLUSH *) -let pp_with ft strm = - pp_dirs ft [< 'Ppdir_ppcmds strm >] - -let ppnl_with ft strm = - pp_dirs ft [< 'Ppdir_ppcmds [< strm ; 'Ppcmd_force_newline >] >] - -let default_warn_with ft strm = ppnl_with ft (warnbody strm) - -let pp_warn_with = ref default_warn_with - -let set_warning_function pp_warn = pp_warn_with := pp_warn - -let warn_with ft strm = !pp_warn_with ft strm - -let warning_with ft string = warn_with ft (str string) - -let pp_flush_with ft = Format.pp_print_flush ft - -(* pretty printing functions WITH FLUSH *) -let msg_with ft strm = - pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_flush >] - -let msgnl_with ft strm = - pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_newline >] - -let msg_warning_with ft strm = - msgnl_with ft (warnbody strm) - -(* pretty printing functions WITHOUT FLUSH *) -let pp x = pp_with !std_ft x -let ppnl x = ppnl_with !std_ft x -let pperr x = pp_with !err_ft x -let pperrnl x = ppnl_with !err_ft x -let message s = ppnl (str s) -let warning x = warning_with !err_ft x -let warn x = warn_with !err_ft x -let pp_flush x = Format.pp_print_flush !std_ft x -let flush_all() = flush stderr; flush stdout; pp_flush() - -(* pretty printing functions WITH FLUSH *) -let msg x = msg_with !std_ft x -let msgnl x = msgnl_with !std_ft x -let msgerr x = msg_with !err_ft x -let msgerrnl x = msgnl_with !err_ft x -let msg_warning x = msg_warning_with !err_ft x -let msg_warn x = msg_warning (str x) - -(* Same specific display in emacs as warning, but without the "Warning:" *) -let msg_debug x = msgnl (emacs_quote x) - -let string_of_ppcmds c = - msg_with Format.str_formatter c; - Format.flush_str_formatter () @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp_control - (** Modify pretty printing functions behavior for emacs ouput (special chars inserted at some places). This function should called once in module [Options], that's all. *) @@ -16,11 +14,9 @@ val make_pp_nonemacs:unit -> unit (** Pretty-printers. *) -type ppcmd - -type std_ppcmds = ppcmd Stream.t +type std_ppcmds -(** {6 Formatting commands. } *) +(** {6 Formatting commands} *) val str : string -> std_ppcmds val stras : int * string -> std_ppcmds @@ -36,15 +32,24 @@ val ismt : std_ppcmds -> bool val comment : int -> std_ppcmds val comments : ((int * int) * string) list ref -(** {6 Concatenation. } *) +(** {6 Manipulation commands} *) -val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds +val app : std_ppcmds -> std_ppcmds -> std_ppcmds +(** Concatenation. *) -(** {6 Evaluation. } *) +val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds +(** Infix alias for [app]. *) val eval_ppcmds : std_ppcmds -> std_ppcmds +(** Force computation. *) + +val is_empty : std_ppcmds -> bool +(** Test emptyness. *) -(** {6 Derived commands. } *) +val rewrite : (string -> string) -> std_ppcmds -> std_ppcmds +(** [rewrite f pps] applies [f] to all strings that appear in [pps]. *) + +(** {6 Derived commands} *) val spc : unit -> std_ppcmds val cut : unit -> std_ppcmds @@ -57,9 +62,7 @@ val qs : string -> std_ppcmds val quote : std_ppcmds -> std_ppcmds val strbrk : string -> std_ppcmds -val xmlescape : ppcmd -> ppcmd - -(** {6 Boxing commands. } *) +(** {6 Boxing commands} *) val h : int -> std_ppcmds -> std_ppcmds val v : int -> std_ppcmds -> std_ppcmds @@ -67,7 +70,7 @@ val hv : int -> std_ppcmds -> std_ppcmds val hov : int -> std_ppcmds -> std_ppcmds val t : std_ppcmds -> std_ppcmds -(** {6 Opening and closing of boxes. } *) +(** {6 Opening and closing of boxes} *) val hb : int -> std_ppcmds val vb : int -> std_ppcmds @@ -77,48 +80,200 @@ val tb : unit -> std_ppcmds val close : unit -> std_ppcmds val tclose : unit -> std_ppcmds -(** {6 Pretty-printing functions {% \emph{%}without flush{% }%}. } *) +(** {6 Opening and closing of tags} *) -val pp_with : Format.formatter -> std_ppcmds -> unit -val ppnl_with : Format.formatter -> std_ppcmds -> unit -val warning_with : Format.formatter -> string -> unit -val warn_with : Format.formatter -> std_ppcmds -> unit -val pp_flush_with : Format.formatter -> unit -> unit +module Tag : +sig + type t + (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *) -val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit + type 'a key + (** Keys used to inject tags *) -(** {6 Pretty-printing functions {% \emph{%}with flush{% }%}. } *) + val create : string -> 'a key + (** Create a key with the given name. Two keys cannot share the same name, if + ever this is the case this function raises an assertion failure. *) -val msg_with : Format.formatter -> std_ppcmds -> unit -val msgnl_with : Format.formatter -> std_ppcmds -> unit + val inj : 'a -> 'a key -> t + (** Inject an object into a tag. *) + + val prj : t -> 'a key -> 'a option + (** Project an object from a tag. *) +end + +type tag_handler = Tag.t -> Format.tag + +val tag : Tag.t -> std_ppcmds -> std_ppcmds +val open_tag : Tag.t -> std_ppcmds +val close_tag : unit -> std_ppcmds + +(** {6 Sending messages to the user} *) +type message_level = Feedback.message_level = + | Debug of string + | Info + | Notice + | Warning + | Error + +type message = Feedback.message = { + message_level : message_level; + message_content : string; +} + +type logger = message_level -> std_ppcmds -> unit + +(** {6 output functions} + +[msg_notice] do not put any decoration on output by default. If +possible don't mix it with goal output (prefer msg_info or +msg_warning) so that interfaces can dispatch outputs easily. Once all +interfaces use the xml-like protocol this constraint can be +relaxed. *) +(* Should we advertise these functions more? Should they be the ONLY + allowed way to output something? *) + +val msg_info : std_ppcmds -> unit +(** Message that displays information, usually in verbose mode, such as [Foobar + is defined] *) + +val msg_notice : std_ppcmds -> unit +(** Message that should be displayed, such as [Print Foo] or [Show Bar]. *) + +val msg_warning : std_ppcmds -> unit +(** Message indicating that something went wrong, but without serious + consequences. *) + +val msg_error : std_ppcmds -> unit +(** Message indicating that something went really wrong, though still + recoverable; otherwise an exception would have been raised. *) + +val msg_debug : std_ppcmds -> unit +(** For debugging purposes *) + +val std_logger : logger +(** Standard logging function *) + +val set_logger : logger -> unit + +val log_via_feedback : unit -> unit + +val of_message : message -> Xml_datatype.xml +val to_message : Xml_datatype.xml -> message +val is_message : Xml_datatype.xml -> bool + + +(** {6 Feedback sent, even asynchronously, to the user interface} *) + +(* This stuff should be available to most of the system, line msg_* above. + * But I'm unsure this is the right place, especially for the global edit_id. + * + * Morally the parser gets a string and an edit_id, and gives back an AST. + * Feedbacks during the parsing phase are attached to this edit_id. + * The interpreter assignes an exec_id to the ast, and feedbacks happening + * during interpretation are attached to the exec_id. + * Only one among state_id and edit_id can be provided. *) + +val feedback : + ?state_id:Feedback.state_id -> ?edit_id:Feedback.edit_id -> + ?route:Feedback.route_id -> Feedback.feedback_content -> unit + +val set_id_for_feedback : + ?route:Feedback.route_id -> Feedback.edit_or_state_id -> unit +val set_feeder : (Feedback.feedback -> unit) -> unit +val get_id_for_feedback : unit -> Feedback.edit_or_state_id * Feedback.route_id + +(** {6 Utilities} *) +val string_of_ppcmds : std_ppcmds -> string + +(** {6 Printing combinators} *) + +val pr_comma : unit -> std_ppcmds +(** Well-spaced comma. *) + +val pr_semicolon : unit -> std_ppcmds +(** Well-spaced semicolon. *) + +val pr_bar : unit -> std_ppcmds +(** Well-spaced pipe bar. *) + +val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds +(** Adds a space in front of its argument. *) + +val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +(** Inner object preceded with a space if [Some], nothing otherwise. *) + +val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +(** Same as [pr_opt] but without the leading space. *) + +val pr_nth : int -> std_ppcmds +(** Ordinal number with the correct suffix (i.e. "st", "nd", "th", etc.). *) + +val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +(** Concatenation of the list contents, without any separator. + + Unlike all other functions below, [prlist] works lazily. If a strict + behavior is needed, use [prlist_strict] instead. *) + +val prlist_strict : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +(** Same as [prlist], but strict. *) + +val prlist_with_sep : + (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a list -> std_ppcmds +(** [prlist_with_sep sep pr [a ; ... ; c]] outputs + [pr a ++ sep() ++ ... ++ sep() ++ pr c]. *) + +val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds +(** As [prlist], but on arrays. *) + +val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds +(** Indexed version of [prvect]. *) + +val prvect_with_sep : + (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds +(** As [prlist_with_sep], but on arrays. *) + +val prvecti_with_sep : + (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds +(** Indexed version of [prvect_with_sep]. *) -(** {6 ... } *) -(** The following functions are instances of the previous ones on - [std_ft] and [err_ft]. *) +val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +(** [pr_enum pr [a ; b ; ... ; c]] outputs + [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c]. *) + +val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +(** Sequence of objects separated by space (unless an element is empty). *) + +val surround : std_ppcmds -> std_ppcmds +(** Surround with parenthesis. *) + +val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds + +(** {6 Low-level pretty-printing functions {% \emph{%}without flush{% }%}. } *) + +val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit (** {6 Pretty-printing functions {% \emph{%}without flush{% }%} on [stdout] and [stderr]. } *) +(** These functions are low-level interface to printing and should not be used + in usual code. Consider using the [msg_*] function family instead. *) + val pp : std_ppcmds -> unit val ppnl : std_ppcmds -> unit val pperr : std_ppcmds -> unit val pperrnl : std_ppcmds -> unit -val message : string -> unit (** = pPNL *) -val warning : string -> unit -val warn : std_ppcmds -> unit +val pperr_flush : unit -> unit val pp_flush : unit -> unit val flush_all: unit -> unit -(** {6 Pretty-printing functions {% \emph{%}with flush{% }%} on [stdout] and [stderr]. } *) +(** {6 Deprecated functions} *) + +(** DEPRECATED. Do not use in newly written code. *) + +val msg_with : Format.formatter -> std_ppcmds -> unit val msg : std_ppcmds -> unit val msgnl : std_ppcmds -> unit val msgerr : std_ppcmds -> unit val msgerrnl : std_ppcmds -> unit -val msg_warning : std_ppcmds -> unit -val msg_warn : string -> unit - -(** Same specific display in emacs as warning, but without the "Warning:" **) -val msg_debug : std_ppcmds -> unit - -val string_of_ppcmds : std_ppcmds -> string +val message : string -> unit (** = pPNL *) diff --git a/lib/pp_control.ml b/lib/pp_control.ml index 94fdb881..0d224c03 100644 --- a/lib/pp_control.ml +++ b/lib/pp_control.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -82,6 +82,7 @@ let set_depth_boxes v = let get_margin () = Some (Format.pp_get_margin !std_ft ()) let set_margin v = let v = match v with None -> default_margin | Some v -> v in + Format.pp_set_margin Format.str_formatter v; Format.pp_set_margin !std_ft v; Format.pp_set_margin !deep_ft v diff --git a/lib/pp_control.mli b/lib/pp_control.mli index 2c2d00f3..28d2e299 100644 --- a/lib/pp_control.mli +++ b/lib/pp_control.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/predicate.ml b/lib/predicate.ml index e419aa6e..a60b3dad 100644 --- a/lib/predicate.ml +++ b/lib/predicate.ml @@ -54,8 +54,8 @@ module Make(Ord: OrderedType) = let full = (true,EltSet.empty) (* assumes the set is infinite *) - let is_empty (b,s) = not b & EltSet.is_empty s - let is_full (b,s) = b & EltSet.is_empty s + let is_empty (b,s) = not b && EltSet.is_empty s + let is_full (b,s) = b && EltSet.is_empty s let mem x (b,s) = if b then not (EltSet.mem x s) else EltSet.mem x s @@ -92,6 +92,6 @@ module Make(Ord: OrderedType) = | ((true,_),(false,_)) -> false let equal (b1,s1) (b2,s2) = - b1=b2 & EltSet.equal s1 s2 + b1=b2 && EltSet.equal s1 s2 end diff --git a/lib/profile.ml b/lib/profile.ml index 0e4c2ebf..c55064ca 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -221,7 +221,7 @@ let loops = 10000 let time_overhead_A_D () = let e = create_record () in let before = get_time () in - for i=1 to loops do + for _i = 1 to loops do (* This is a copy of profile1 for overhead estimation *) let dw = dummy_spent_alloc () in match !dummy_stack with [] -> assert false | p::_ -> @@ -245,7 +245,7 @@ let time_overhead_A_D () = done; let after = get_time () in let beforeloop = get_time () in - for i=1 to loops do () done; + for _i = 1 to loops do () done; let afterloop = get_time () in float_of_int ((after - before) - (afterloop - beforeloop)) /. float_of_int loops @@ -253,18 +253,18 @@ let time_overhead_A_D () = let time_overhead_B_C () = let dummy_x = 0 in let before = get_time () in - for i=1 to loops do + for _i = 1 to loops do try dummy_last_alloc := get_alloc (); let _r = dummy_f dummy_x in let _dw = dummy_spent_alloc () in let _dt = get_time () in () - with e when e <> Sys.Break -> assert false + with e when Errors.noncritical e -> assert false done; let after = get_time () in let beforeloop = get_time () in - for i=1 to loops do () done; + for _i = 1 to loops do () done; let afterloop = get_time () in float_of_int ((after - before) - (afterloop - beforeloop)) /. float_of_int loops @@ -279,7 +279,7 @@ let format_profile (table, outside, total) = Printf.printf "%-23s %9s %9s %10s %10s %10s\n" "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls "; - let l = Sort.list (fun (_,{tottime=p}) (_,{tottime=p'}) -> p > p') table in + let l = List.sort (fun (_,{tottime=p}) (_,{tottime=p'}) -> p' - p) table in List.iter (fun (name,e) -> Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f %6d %6d\n" @@ -352,7 +352,7 @@ let close_profile print = let print_profile () = close_profile true let declare_profile name = - if name = "___outside___" or name = "___total___" then + if name = "___outside___" || name = "___total___" then failwith ("Error: "^name^" is a reserved keyword"); let e = create_record () in prof_table := (name,e)::!prof_table; @@ -657,80 +657,57 @@ let profile7 e f a b c d g h i = last_alloc := get_alloc (); raise reraise -(* Some utilities to compute the logical and physical sizes and depth - of ML objects *) - -let c = ref 0 -let s = ref 0 -let b = ref 0 -let m = ref 0 - -let rec obj_stats d t = - if Obj.is_int t then m := max d !m - else if Obj.tag t >= Obj.no_scan_tag then - if Obj.tag t = Obj.string_tag then - (c := !c + Obj.size t; b := !b + 1; m := max d !m) - else if Obj.tag t = Obj.double_tag then - (s := !s + 2; b := !b + 1; m := max d !m) - else if Obj.tag t = Obj.double_array_tag then - (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m) - else (b := !b + 1; m := max d !m) - else - let n = Obj.size t in - s := !s + n; b := !b + 1; - block_stats (d + 1) (n - 1) t - -and block_stats d i t = - if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t) - -let obj_stats a = - c := 0; s:= 0; b:= 0; m:= 0; - obj_stats 0 (Obj.repr a); - (!c, !s + !b, !m) - -module H = Hashtbl.Make( - struct - type t = Obj.t - let equal = (==) - let hash o = Hashtbl.hash (Obj.magic o : int) - end) - -let tbl = H.create 13 - -let rec obj_shared_size s t = - if Obj.is_int t then s - else if H.mem tbl t then s - else begin - H.add tbl t (); - let n = Obj.size t in - if Obj.tag t >= Obj.no_scan_tag then - if Obj.tag t = Obj.string_tag then (c := !c + n; s + 1) - else if Obj.tag t = Obj.double_tag then s + 3 - else if Obj.tag t = Obj.double_array_tag then s + 2 * n + 1 - else s + 1 - else - block_shared_size (s + n + 1) (n - 1) t - end - -and block_shared_size s i t = - if i < 0 then s - else block_shared_size (obj_shared_size s (Obj.field t i)) (i-1) t - -let obj_shared_size a = - H.clear tbl; - c := 0; - let s = obj_shared_size 0 (Obj.repr a) in - (!c, s) +let profile8 e f a b c d g h i j = + let dw = spent_alloc () in + match !stack with [] -> assert false | p::_ -> + (* We add spent alloc since last measure to current caller own/total alloc *) + ajoute_ownalloc p dw; + ajoute_totalloc p dw; + e.owncount <- e.owncount + 1; + if not (p==e) then stack := e::!stack; + let totalloc0 = e.totalloc in + let intcount0 = e.intcount in + let t = get_time () in + try + last_alloc := get_alloc (); + let r = f a b c d g h i j in + let dw = spent_alloc () in + let dt = get_time () - t in + e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; + ajoute_ownalloc e dw; + ajoute_totalloc e dw; + p.owntime <- p.owntime - dt; + ajoute_totalloc p (e.totalloc -. totalloc0); + p.intcount <- p.intcount + e.intcount - intcount0 + 1; + p.immcount <- p.immcount + 1; + if not (p==e) then + (match !stack with [] -> assert false | _::s -> stack := s); + last_alloc := get_alloc (); + r + with reraise -> + let dw = spent_alloc () in + let dt = get_time () - t in + e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; + ajoute_ownalloc e dw; + ajoute_totalloc e dw; + p.owntime <- p.owntime - dt; + ajoute_totalloc p (e.totalloc -. totalloc0); + p.intcount <- p.intcount + e.intcount - intcount0 + 1; + p.immcount <- p.immcount + 1; + if not (p==e) then + (match !stack with [] -> assert false | _::s -> stack := s); + last_alloc := get_alloc (); + raise reraise let print_logical_stats a = - let (c, s, d) = obj_stats a in + let (c, s, d) = CObj.obj_stats a in Printf.printf "Expanded size: %10d (str: %8d) Depth: %6d\n" (s+c) c d let print_stats a = - let (c1, s, d) = obj_stats a in - let (c2, o) = obj_shared_size a in - Printf.printf "Size: %8d (str: %8d) (exp: %10d) Depth: %6d\n" - (o + c2) c2 (s + c1) d + let (c1, s, d) = CObj.obj_stats a in + let c2 = CObj.size a in + Printf.printf "Size: %8d (exp: %10d) Depth: %6d\n" + c2 (s + c1) d (* let _ = Gc.set { (Gc.get()) with Gc.verbose = 13 } *) diff --git a/lib/profile.mli b/lib/profile.mli index 1e45ceed..e3221cd2 100644 --- a/lib/profile.mli +++ b/lib/profile.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -100,6 +100,10 @@ val profile7 : profile_key -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h +val profile8 : + profile_key -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i) + -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i (** Some utilities to compute the logical and physical sizes and depth @@ -113,12 +117,3 @@ val print_logical_stats : 'a -> unit This function allocates itself a lot (the same order of magnitude as the physical size of its argument) *) val print_stats : 'a -> unit - -(** Return logical size (first for strings, then for not strings), - (in words) and depth of its argument - This function allocates itself a lot *) -val obj_stats : 'a -> int * int * int - -(** Return physical size of its argument (string part and rest) - This function allocates itself a lot *) -val obj_shared_size : 'a -> int * int diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml new file mode 100644 index 00000000..f4d7bb7b --- /dev/null +++ b/lib/remoteCounter.ml @@ -0,0 +1,48 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type 'a getter = unit -> 'a +type 'a installer = ('a getter) -> unit + +type remote_counters_status = (string * Obj.t) list + +let counters : remote_counters_status ref = ref [] + +let (!!) x = !(!x) + +let new_counter ~name a ~incr ~build = + assert(not (List.mem_assoc name !counters)); + let data = ref (ref a) in + counters := (name, Obj.repr data) :: !counters; + let m = Mutex.create () in + let mk_thsafe_getter f () = + (* - slaves must use a remote counter getter, not this one! *) + (* - in the main process there is a race condition between slave + managers (that are threads) and the main thread, hence the mutex *) + if Flags.async_proofs_is_worker () then + Errors.anomaly(Pp.str"Slave processes must install remote counters"); + Mutex.lock m; let x = f () in Mutex.unlock m; + build x in + let getter = ref(mk_thsafe_getter (fun () -> !data := incr !!data; !!data)) in + let installer f = + if not (Flags.async_proofs_is_worker ()) then + Errors.anomaly(Pp.str"Only slave processes can install a remote counter"); + getter := f in + (fun () -> !getter ()), installer + +let backup () = !counters + +let snapshot () = + List.map (fun (n,v) -> n, Obj.repr (ref (ref !!(Obj.obj v)))) !counters + +let restore l = + List.iter (fun (name, data) -> + assert(List.mem_assoc name !counters); + let dataref = Obj.obj (List.assoc name !counters) in + !dataref := !!(Obj.obj data)) + l diff --git a/lib/remoteCounter.mli b/lib/remoteCounter.mli new file mode 100644 index 00000000..f3eca418 --- /dev/null +++ b/lib/remoteCounter.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Remote counters are *global* counters for fresh ids. In the master/slave + * scenario, the slave installs a getter that asks the master for a fresh + * value. In the scenario of a slave that runs after the death of the master + * on some marshalled data, a backup of all counters status should be taken and + * restored to avoid reusing ids. + * Counters cannot be created by threads, they must be created once and forall + * as toplevel module declarations. *) + + +type 'a getter = unit -> 'a +type 'a installer = ('a getter) -> unit + +val new_counter : name:string -> + 'a -> incr:('a -> 'a) -> build:('a -> 'b) -> 'b getter * 'b installer + +type remote_counters_status +val backup : unit -> remote_counters_status +(* like backup but makes a copy so that further increment does not alter + * the snapshot *) +val snapshot : unit -> remote_counters_status +val restore : remote_counters_status -> unit diff --git a/lib/richpp.ml b/lib/richpp.ml new file mode 100644 index 00000000..745b7d2a --- /dev/null +++ b/lib/richpp.ml @@ -0,0 +1,177 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype + +type 'annotation located = { + annotation : 'annotation option; + startpos : int; + endpos : int +} + +let rich_pp annotate ppcmds = + (** First, we use Format to introduce tags inside + the pretty-printed document. + + Each inserted tag is a fresh index that we keep in sync with the contents + of annotations. + *) + let annotations = ref [] in + let index = ref (-1) in + let pp_tag obj = + let () = incr index in + let () = annotations := obj :: !annotations in + string_of_int !index + in + + let tagged_pp = Format.( + + (** Warning: The following instructions are valid only if + [str_formatter] is not used for another purpose in + Pp.pp_with. *) + + let ft = str_formatter in + + (** We reuse {!Format} standard way of producing tags + inside pretty-printing. *) + pp_set_tags ft true; + + (** The whole output must be a valid document. To that + end, we nest the document inside a tag named <pp>. *) + pp_open_tag ft "pp"; + + (** XML ignores spaces. The problem is that our pretty-printings + are based on spaces to indent. To solve that problem, we + systematically output non-breakable spaces, which are properly + honored by XML. + + To do so, we reconfigure the [str_formatter] temporarily by + hijacking the function that output spaces. *) + let out, flush, newline, std_spaces = + pp_get_all_formatter_output_functions ft () + in + let set = pp_set_all_formatter_output_functions ft ~out ~flush ~newline in + set ~spaces:(fun k -> + for i = 0 to k - 1 do + Buffer.add_string stdbuf " " + done + ); + + (** Some characters must be escaped in XML. This is done by the + following rewriting of the strings held by pretty-printing + commands. *) + Pp.(pp_with ~pp_tag ft (rewrite Xml_printer.pcdata_to_string ppcmds)); + + (** Insert </pp>. *) + pp_close_tag ft (); + + (** Get the final string. *) + let output = flush_str_formatter () in + + (** Finalize by restoring the state of the [str_formatter] and the + default behavior of Format. By the way, there may be a bug here: + there is no {!Format.pp_get_tags} and therefore if the tags flags + was already set to true before executing this piece of code, the + state of Format is not restored. *) + set ~spaces:std_spaces; + pp_set_tags ft false; + output + ) + in + (** Second, we retrieve the final function that relates + each tag to an annotation. *) + let objs = CArray.rev_of_list !annotations in + let get index = annotate objs.(index) in + + (** Third, we parse the resulting string. It is a valid XML + document (in the sense of Xml_parser). As blanks are + meaningful we deactivate canonicalization in the XML + parser. *) + let xml_pp = + try + Xml_parser.(parse ~do_not_canonicalize:true (make (SString tagged_pp))) + with Xml_parser.Error e -> + Printf.eprintf + "Broken invariant (RichPp): \n\ + The output semi-structured pretty-printing is ill-formed.\n\ + Please report.\n\ + %s" + (Xml_parser.error e); + exit 1 + in + + (** Fourth, the low-level XML is turned into a high-level + semi-structured document that contains a located annotation in + every node. During the traversal of the low-level XML document, + we build a raw string representation of the pretty-print. *) + let rec node buffer = function + | Element (index, [], cs) -> + let startpos, endpos, cs = children buffer cs in + let annotation = try get (int_of_string index) with _ -> None in + (Element (index, { annotation; startpos; endpos }, cs), endpos) + + | PCData s -> + Buffer.add_string buffer s; + (PCData s, Buffer.length buffer) + + | _ -> + assert false (* Because of the form of XML produced by Format. *) + + and children buffer cs = + let startpos = Buffer.length buffer in + let cs, endpos = + List.fold_left (fun (cs, endpos) c -> + let c, endpos = node buffer c in + (c :: cs, endpos) + ) ([], startpos) cs + in + (startpos, endpos, List.rev cs) + in + let pp_buffer = Buffer.create 13 in + let xml, _ = node pp_buffer xml_pp in + + (** We return the raw pretty-printing and its annotations tree. *) + (Buffer.contents pp_buffer, xml) + +let annotations_positions xml = + let rec node accu = function + | Element (_, { annotation = Some annotation; startpos; endpos }, cs) -> + children ((annotation, (startpos, endpos)) :: accu) cs + | Element (_, _, cs) -> + children accu cs + | _ -> + accu + and children accu cs = + List.fold_left node accu cs + in + node [] xml + +let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = + let rec node = function + | Element (index, { annotation; startpos; endpos }, cs) -> + let attributes = + [ "startpos", string_of_int startpos; + "endpos", string_of_int endpos + ] + @ (match annotation with + | None -> [] + | Some annotation -> attributes_of_annotation annotation + ) + in + let tag = + match annotation with + | None -> index + | Some annotation -> tag_of_annotation annotation + in + Element (tag, attributes, List.map node cs) + | PCData s -> + PCData s + in + node xml + + diff --git a/lib/richpp.mli b/lib/richpp.mli new file mode 100644 index 00000000..446ee1a0 --- /dev/null +++ b/lib/richpp.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This module offers semi-structured pretty-printing. *) + +(** Each annotation of the semi-structured document refers to the + substring it annotates. *) +type 'annotation located = { + annotation : 'annotation option; + startpos : int; + endpos : int +} + +(** [rich_pp get_annotations ppcmds] returns the interpretation + of [ppcmds] as a string as well as a semi-structured document + that represents (located) annotations of this string. + The [get_annotations] function is used to convert tags into the desired + annotation. If this function returns [None], then no annotation is put. *) +val rich_pp : + (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds -> + string * 'annotation located Xml_datatype.gxml + +(** [annotations_positions ssdoc] returns a list associating each + annotations with its position in the string from which [ssdoc] is + built. *) +val annotations_positions : + 'annotation located Xml_datatype.gxml -> + ('annotation * (int * int)) list + +(** [xml_of_rich_pp ssdoc] returns an XML representation of the + semi-structured document [ssdoc]. *) +val xml_of_rich_pp : + ('annotation -> string) -> + ('annotation -> (string * string) list) -> + 'annotation located Xml_datatype.gxml -> + Xml_datatype.xml diff --git a/lib/rtree.ml b/lib/rtree.ml index cfac6aa4..f395c086 100644 --- a/lib/rtree.ml +++ b/lib/rtree.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,17 +8,15 @@ open Util - (* Type of regular trees: - Param denotes tree variables (like de Bruijn indices) the first int is the depth of the occurrence, and the second int - is the index in the array of trees introduced at that depth + is the index in the array of trees introduced at that depth. + Warning: Param's indices both start at 0! - Node denotes the usual tree node, labelled with 'a - Rec(j,v1..vn) introduces infinite tree. It denotes v(j+1) with parameters 0..n-1 replaced by Rec(0,v1..vn)..Rec(n-1,v1..vn) respectively. - Parameters n and higher denote parameters global to the - current Rec node (as usual in de Bruijn binding system) *) type 'a t = Param of int * int @@ -36,27 +34,26 @@ let rec lift_rtree_rec depth n = function | Rec(j,defs) -> Rec(j, Array.map (lift_rtree_rec (depth+1) n) defs) -let lift n t = if n=0 then t else lift_rtree_rec 0 n t +let lift n t = if Int.equal n 0 then t else lift_rtree_rec 0 n t (* The usual subst operation *) let rec subst_rtree_rec depth sub = function Param (i,j) as t -> if i < depth then t - else if i-depth < Array.length sub then - lift depth sub.(i-depth).(j) - else Param (i-Array.length sub,j) + else if i = depth then + lift depth (Rec (j, sub)) + else Param (i - 1, j) | Node (l,sons) -> Node (l,Array.map (subst_rtree_rec depth sub) sons) | Rec(j,defs) -> Rec(j, Array.map (subst_rtree_rec (depth+1) sub) defs) -let subst_rtree sub t = subst_rtree_rec 0 [|sub|] t +let subst_rtree sub t = subst_rtree_rec 0 sub t (* To avoid looping, we must check that every body introduces a node or a parameter *) let rec expand = function | Rec(j,defs) -> - let sub = Array.init (Array.length defs) (fun i -> Rec(i,defs)) in - expand (subst_rtree sub defs.(j)) + expand (subst_rtree defs defs.(j)) | t -> t (* Given a vector of n bodies, builds the n mutual recursive trees. @@ -65,12 +62,13 @@ let rec expand = function directly one of the parameters of depth 0. Some care is taken to accept definitions like rec X=Y and Y=f(X,Y) *) let mk_rec defs = - let rec check histo d = - match expand d with - Param(0,j) when List.mem j histo -> failwith "invalid rec call" - | Param(0,j) -> check (j::histo) defs.(j) - | _ -> () in - Array.mapi (fun i d -> check [i] d; Rec(i,defs)) defs + let rec check histo d = match expand d with + | Param (0, j) -> + if Int.Set.mem j histo then failwith "invalid rec call" + else check (Int.Set.add j histo) defs.(j) + | _ -> () + in + Array.mapi (fun i d -> check (Int.Set.singleton i) d; Rec(i,defs)) defs (* let v(i,j) = lift i (mk_rec_calls(j+1)).(j);; let r = (mk_rec[|(mk_rec[|v(1,0)|]).(0)|]).(0);; @@ -100,69 +98,96 @@ let rec map f t = match t with | Node (a,sons) -> Node (f a, Array.map (map f) sons) | Rec(j,defs) -> Rec (j, Array.map (map f) defs) -let rec smartmap f t = match t with +let smartmap f t = match t with Param _ -> t | Node (a,sons) -> - let a'=f a and sons' = Util.array_smartmap (map f) sons in - if a'==a && sons'==sons then - t - else - Node (a',sons') + let a'=f a and sons' = Array.smartmap (map f) sons in + if a'==a && sons'==sons then t + else Node (a',sons') | Rec(j,defs) -> - let defs' = Util.array_smartmap (map f) defs in - if defs'==defs then - t - else - Rec(j,defs') - -(* Fixpoint operator on trees: - f is the body of the fixpoint. Arguments passed to f are: - - a boolean telling if the subtree has already been seen - - the current subtree - - a function to make recursive calls on subtrees - *) -let fold f t = - let rec fold histo t = - let seen = List.mem t histo in - let nhisto = if not seen then t::histo else histo in - f seen (expand t) (fold nhisto) in - fold [] t - - -(* Tests if a given tree is infinite, i.e. has an branch of infinte length. *) -let is_infinite t = fold - (fun seen t is_inf -> - seen || - (match t with - Node(_,v) -> array_exists is_inf v - | Param _ -> false - | _ -> assert false)) - t - -let fold2 f t x = - let rec fold histo t x = - let seen = List.mem (t,x) histo in - let nhisto = if not seen then (t,x)::histo else histo in - f seen (expand t) x (fold nhisto) in - fold [] t x - -let compare_rtree f = fold2 - (fun seen t1 t2 cmp -> - seen || - let b = f t1 t2 in - if b < 0 then false - else if b > 0 then true - else match expand t1, expand t2 with - Node(_,v1), Node(_,v2) when Array.length v1 = Array.length v2 -> - array_for_all2 cmp v1 v2 - | _ -> false) - -let eq_rtree cmp t1 t2 = - t1 == t2 || t1=t2 || - compare_rtree - (fun t1 t2 -> - if cmp (fst(dest_node t1)) (fst(dest_node t2)) then 0 - else (-1)) t1 t2 + let defs' = Array.smartmap (map f) defs in + if defs'==defs then t + else Rec(j,defs') + +(** Structural equality test, parametrized by an equality on elements *) + +let rec raw_eq cmp t t' = match t, t' with + | Param (i,j), Param (i',j') -> Int.equal i i' && Int.equal j j' + | Node (x, a), Node (x', a') -> cmp x x' && Array.equal (raw_eq cmp) a a' + | Rec (i, a), Rec (i', a') -> Int.equal i i' && Array.equal (raw_eq cmp) a a' + | _ -> false + +let raw_eq2 cmp (t,u) (t',u') = raw_eq cmp t t' && raw_eq cmp u u' + +(** Equivalence test on expanded trees. It is parametrized by two + equalities on elements: + - [cmp] is used when checking for already seen trees + - [cmp'] is used when comparing node labels. *) + +let equiv cmp cmp' = + let rec compare histo t t' = + List.mem_f (raw_eq2 cmp) (t,t') histo || + match expand t, expand t' with + | Node(x,v), Node(x',v') -> + cmp' x x' && + Int.equal (Array.length v) (Array.length v') && + Array.for_all2 (compare ((t,t')::histo)) v v' + | _ -> false + in compare [] + +(** The main comparison on rtree tries first physical equality, then + the structural one, then the logical equivalence *) + +let equal cmp t t' = + t == t' || raw_eq cmp t t' || equiv cmp cmp t t' + +(** Deprecated alias *) +let eq_rtree = equal + +(** Intersection of rtrees of same arity *) +let rec inter cmp interlbl def n histo t t' = + try + let (i,j) = List.assoc_f (raw_eq2 cmp) (t,t') histo in + Param (n-i-1,j) + with Not_found -> + match t, t' with + | Param (i,j), Param (i',j') -> + assert (Int.equal i i' && Int.equal j j'); t + | Node (x, a), Node (x', a') -> + (match interlbl x x' with + | None -> mk_node def [||] + | Some x'' -> Node (x'', Array.map2 (inter cmp interlbl def n histo) a a')) + | Rec (i,v), Rec (i',v') -> + (* If possible, we preserve the shape of input trees *) + if Int.equal i i' && Int.equal (Array.length v) (Array.length v') then + let histo = ((t,t'),(n,i))::histo in + Rec(i, Array.map2 (inter cmp interlbl def (n+1) histo) v v') + else + (* Otherwise, mutually recursive trees are transformed into nested trees *) + let histo = ((t,t'),(n,0))::histo in + Rec(0, [|inter cmp interlbl def (n+1) histo (expand t) (expand t')|]) + | Rec _, _ -> inter cmp interlbl def n histo (expand t) t' + | _ , Rec _ -> inter cmp interlbl def n histo t (expand t') + | _ -> assert false + +let inter cmp interlbl def t t' = inter cmp interlbl def 0 [] t t' + +(** Inclusion of rtrees. We may want a more efficient implementation. *) +let incl cmp interlbl def t t' = + equal cmp t (inter cmp interlbl def t t') + +(** Tests if a given tree is infinite, i.e. has a branch of infinite length. + This corresponds to a cycle when visiting the expanded tree. + We use a specific comparison to detect already seen trees. *) + +let is_infinite cmp t = + let rec is_inf histo t = + List.mem_f (raw_eq cmp) t histo || + match expand t with + | Node (_,v) -> Array.exists (is_inf (t::histo)) v + | _ -> false + in + is_inf [] t (* Pretty-print a tree (not so pretty) *) open Pp @@ -173,11 +198,11 @@ let rec pp_tree prl t = | Node(lab,[||]) -> hov 2 (str"("++prl lab++str")") | Node(lab,v) -> hov 2 (str"("++prl lab++str","++brk(1,0)++ - Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str")") + prvect_with_sep pr_comma (pp_tree prl) v++str")") | Rec(i,v) -> - if Array.length v = 0 then str"Rec{}" - else if Array.length v = 1 then + if Int.equal (Array.length v) 0 then str"Rec{}" + else if Int.equal (Array.length v) 1 then hov 2 (str"Rec{"++pp_tree prl v.(0)++str"}") else hov 2 (str"Rec{"++int i++str","++brk(1,0)++ - Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str"}") + prvect_with_sep pr_comma (pp_tree prl) v++str"}") diff --git a/lib/rtree.mli b/lib/rtree.mli index 8b12fee1..0b9424b8 100644 --- a/lib/rtree.mli +++ b/lib/rtree.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Type of regular tree with nodes labelled by values of type 'a +(** Type of regular tree with nodes labelled by values of type 'a The implementation uses de Bruijn indices, so binding capture is avoided by the lift operator (see example below) *) type 'a t @@ -49,22 +49,26 @@ val dest_node : 'a t -> 'a * 'a t array (** dest_param is not needed for closed trees (i.e. with no free variable) *) val dest_param : 'a t -> int * int -(** Tells if a tree has an infinite branch *) -val is_infinite : 'a t -> bool - -(** [compare_rtree f t1 t2] compares t1 t2 (top-down). - f is called on each node: if the result is negative then the - traversal ends on false, it is is positive then deeper nodes are - not examined, and the traversal continues on respective siblings, - and if it is 0, then the traversal continues on sons, pairwise. - In this latter case, if the nodes do not have the same number of - sons, then the traversal ends on false. - In case of loop, the traversal is successful and it resumes on - siblings. - *) -val compare_rtree : ('a t -> 'b t -> int) -> 'a t -> 'b t -> bool +(** Tells if a tree has an infinite branch. The first arg is a comparison + used to detect already seen elements, hence loops *) +val is_infinite : ('a -> 'a -> bool) -> 'a t -> bool -val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool +(** [Rtree.equiv eq eqlab t1 t2] compares t1 t2 (top-down). + If t1 and t2 are both nodes, [eqlab] is called on their labels, + in case of success deeper nodes are examined. + In case of loop (detected via structural equality parametrized + by [eq]), then the comparison is successful. *) +val equiv : + ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + +(** [Rtree.equal eq t1 t2] compares t1 and t2, first via physical + equality, then by structural equality (using [eq] on elements), + then by logical equivalence [Rtree.equiv eq eq] *) +val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + +val inter : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t -> 'a t + +val incl : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t -> bool (** Iterators *) @@ -72,9 +76,9 @@ val map : ('a -> 'b) -> 'a t -> 'b t (** [(smartmap f t) == t] if [(f a) ==a ] for all nodes *) val smartmap : ('a -> 'a) -> 'a t -> 'a t -val fold : (bool -> 'a t -> ('a t -> 'b) -> 'b) -> 'a t -> 'b -val fold2 : - (bool -> 'a t -> 'b -> ('a t -> 'b -> 'c) -> 'c) -> 'a t -> 'b -> 'c (** A rather simple minded pretty-printer *) val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds + +val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool +(** @deprecated Same as [Rtree.equal] *) diff --git a/lib/serialize.ml b/lib/serialize.ml new file mode 100644 index 00000000..aa2e3f02 --- /dev/null +++ b/lib/serialize.ml @@ -0,0 +1,116 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype + +exception Marshal_error + +(** Utility functions *) + +let rec get_attr attr = function + | [] -> raise Not_found + | (k, v) :: l when CString.equal k attr -> v + | _ :: l -> get_attr attr l + +let massoc x l = + try get_attr x l + with Not_found -> raise Marshal_error + +let constructor t c args = Element (t, ["val", c], args) +let do_match t mf = function + | Element (s, attrs, args) when CString.equal s t -> + let c = massoc "val" attrs in + mf c args + | _ -> raise Marshal_error + +let singleton = function + | [x] -> x + | _ -> raise Marshal_error + +let raw_string = function + | [] -> "" + | [PCData s] -> s + | _ -> raise Marshal_error + +(** Base types *) + +let of_unit () = Element ("unit", [], []) +let to_unit : xml -> unit = function + | Element ("unit", [], []) -> () + | _ -> raise Marshal_error + +let of_bool (b : bool) : xml = + if b then constructor "bool" "true" [] + else constructor "bool" "false" [] +let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with + | "true" -> true + | "false" -> false + | _ -> raise Marshal_error) + +let of_list (f : 'a -> xml) (l : 'a list) = + Element ("list", [], List.map f l) +let to_list (f : xml -> 'a) : xml -> 'a list = function + | Element ("list", [], l) -> List.map f l + | _ -> raise Marshal_error + +let of_option (f : 'a -> xml) : 'a option -> xml = function + | None -> Element ("option", ["val", "none"], []) + | Some x -> Element ("option", ["val", "some"], [f x]) +let to_option (f : xml -> 'a) : xml -> 'a option = function + | Element ("option", ["val", "none"], []) -> None + | Element ("option", ["val", "some"], [x]) -> Some (f x) + | _ -> raise Marshal_error + +let of_string (s : string) : xml = Element ("string", [], [PCData s]) +let to_string : xml -> string = function + | Element ("string", [], l) -> raw_string l + | _ -> raise Marshal_error + +let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)]) +let to_int : xml -> int = function + | Element ("int", [], [PCData s]) -> + (try int_of_string s with Failure _ -> raise Marshal_error) + | _ -> raise Marshal_error + +let of_pair (f : 'a -> xml) (g : 'b -> xml) (x : 'a * 'b) : xml = + Element ("pair", [], [f (fst x); g (snd x)]) +let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function + | Element ("pair", [], [x; y]) -> (f x, g y) + | _ -> raise Marshal_error + +let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = function + | CSig.Inl x -> Element ("union", ["val","in_l"], [f x]) + | CSig.Inr x -> Element ("union", ["val","in_r"], [g x]) +let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) CSig.union = function + | Element ("union", ["val","in_l"], [x]) -> CSig.Inl (f x) + | Element ("union", ["val","in_r"], [x]) -> CSig.Inr (g x) + | _ -> raise Marshal_error + +(** More elaborate types *) + +let of_edit_id i = Element ("edit_id",["val",string_of_int i],[]) +let to_edit_id = function + | Element ("edit_id",["val",i],[]) -> + let id = int_of_string i in + assert (id <= 0 ); + id + | _ -> raise Marshal_error + +let of_loc loc = + let start, stop = Loc.unloc loc in + Element ("loc",[("start",string_of_int start);("stop",string_of_int stop)],[]) +let to_loc xml = + match xml with + | Element ("loc", l,[]) -> + (try + let start = massoc "start" l in + let stop = massoc "stop" l in + Loc.make_loc (int_of_string start, int_of_string stop) + with Not_found | Invalid_argument _ -> raise Marshal_error) + | _ -> raise Marshal_error + diff --git a/lib/serialize.mli b/lib/serialize.mli new file mode 100644 index 00000000..34d3e054 --- /dev/null +++ b/lib/serialize.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype + +exception Marshal_error + +val massoc: string -> (string * string) list -> string +val constructor: string -> string -> xml list -> xml +val do_match: string -> (string -> xml list -> 'b) -> xml -> 'b +val singleton: 'a list -> 'a +val raw_string: xml list -> string +val of_unit: unit -> xml +val to_unit: xml -> unit +val of_bool: bool -> xml +val to_bool: xml -> bool +val of_list: ('a -> xml) -> 'a list -> xml +val to_list: (xml -> 'a) -> xml -> 'a list +val of_option: ('a -> xml) -> 'a option -> xml +val to_option: (xml -> 'a) -> xml -> 'a option +val of_string: string -> xml +val to_string: xml -> string +val of_int: int -> xml +val to_int: xml -> int +val of_pair: ('a -> xml) -> ('b -> xml) -> 'a * 'b -> xml +val to_pair: (xml -> 'a) -> (xml -> 'b) -> xml -> 'a * 'b +val of_union: ('a -> xml) -> ('b -> xml) -> ('a, 'b) CSig.union -> xml +val to_union: (xml -> 'a) -> (xml -> 'b) -> xml -> ('a, 'b) CSig.union +val of_edit_id: int -> xml +val to_edit_id: xml -> int +val of_loc : Loc.t -> xml +val to_loc : xml -> Loc.t diff --git a/lib/spawn.ml b/lib/spawn.ml new file mode 100644 index 00000000..9b63be70 --- /dev/null +++ b/lib/spawn.ml @@ -0,0 +1,258 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +let proto_version = 0 +let prefer_sock = Sys.os_type = "Win32" +let accept_timeout = 2.0 + +let pr_err s = Printf.eprintf "(Spawn ,%d) %s\n%!" (Unix.getpid ()) s +let prerr_endline s = if !Flags.debug then begin pr_err s end else () + +type req = ReqDie | ReqStats | Hello of int * int +type resp = RespStats of Gc.stat + +module type Control = sig + type handle + + val kill : handle -> unit + val stats : handle -> Gc.stat + val wait : handle -> Unix.process_status + val unixpid : handle -> int + val uid : handle -> string + val is_alive : handle -> bool + +end + +module type Empty = sig end + +module type MainLoopModel = sig + type async_chan + type condition + type watch_id + + val add_watch : callback:(condition list -> bool) -> async_chan -> watch_id + val remove_watch : watch_id -> unit + val read_all : async_chan -> string + val async_chan_of_file : Unix.file_descr -> async_chan + val async_chan_of_socket : Unix.file_descr -> async_chan +end + +(* Common code *) +let assert_ b s = if not b then Errors.anomaly (Pp.str s) + +let mk_socket_channel () = + let open Unix in + let s = socket PF_INET SOCK_STREAM 0 in + bind s (ADDR_INET (inet_addr_loopback,0)); + listen s 1; + match getsockname s with + | ADDR_INET(host, port) -> + s, string_of_inet_addr host ^":"^ string_of_int port + | _ -> assert false + +let accept s = + let r, _, _ = Unix.select [s] [] [] accept_timeout in + if r = [] then raise (Failure (Printf.sprintf + "The spawned process did not connect back in %2.1fs" accept_timeout)); + let cs, _ = Unix.accept s in + Unix.close s; + let cin, cout = Unix.in_channel_of_descr cs, Unix.out_channel_of_descr cs in + set_binary_mode_in cin true; + set_binary_mode_out cout true; + cs, cin, cout + +let handshake cin cout = + try + output_value cout (Hello (proto_version,Unix.getpid ())); flush cout; + match input_value cin with + | Hello(v, pid) when v = proto_version -> + prerr_endline (Printf.sprintf "Handshake with %d OK" pid); + pid + | _ -> raise (Failure "handshake protocol") + with + | Failure s | Invalid_argument s | Sys_error s -> + pr_err ("Handshake failed: " ^ s); raise (Failure "handshake") + | End_of_file -> + pr_err "Handshake failed: End_of_file"; raise (Failure "handshake") + +let spawn_sock env prog args = + let main_sock, main_sock_name = mk_socket_channel () in + let extra = [| prog; "-main-channel"; main_sock_name |] in + let args = Array.append extra args in + prerr_endline ("EXEC: " ^ String.concat " " (Array.to_list args)); + let pid = + Unix.create_process_env prog args env Unix.stdin Unix.stdout Unix.stderr in + if pid = 0 then begin + Unix.sleep 1; (* to avoid respawning like crazy *) + raise (Failure "create_process failed") + end; + let cs, cin, cout = accept main_sock in + pid, cin, cout, cs + +let spawn_pipe env prog args = + let master2worker_r,master2worker_w = Unix.pipe () in + let worker2master_r,worker2master_w = Unix.pipe () in + let extra = [| prog; "-main-channel"; "stdfds" |] in + let args = Array.append extra args in + Unix.set_close_on_exec master2worker_w; + Unix.set_close_on_exec worker2master_r; + prerr_endline ("EXEC: " ^ String.concat " " (Array.to_list args)); + let pid = + Unix.create_process_env + prog args env master2worker_r worker2master_w Unix.stderr in + if pid = 0 then begin + Unix.sleep 1; (* to avoid respawning like crazy *) + raise (Failure "create_process failed") + end; + prerr_endline ("PID " ^ string_of_int pid); + Unix.close master2worker_r; + Unix.close worker2master_w; + let cin = Unix.in_channel_of_descr worker2master_r in + let cout = Unix.out_channel_of_descr master2worker_w in + set_binary_mode_in cin true; + set_binary_mode_out cout true; + pid, cin, cout, worker2master_r + +let filter_args args = + let rec aux = function + | "-control-channel" :: _ :: rest -> aux rest + | "-main-channel" :: _ :: rest -> aux rest + | x :: rest -> x :: aux rest + | [] -> [] in + Array.of_list (aux (Array.to_list args)) + +let spawn_with_control prefer_sock env prog args = + let control_sock, control_sock_name = mk_socket_channel () in + let extra = [| "-control-channel"; control_sock_name |] in + let args = Array.append extra (filter_args args) in + let (pid, cin, cout, s), is_sock = + if Sys.os_type <> "Unix" || prefer_sock + then spawn_sock env prog args, true + else spawn_pipe env prog args, false in + let _, oob_resp, oob_req = accept control_sock in + pid, oob_resp, oob_req, cin, cout, s, is_sock + +let output_death_sentence pid oob_req = + prerr_endline ("death sentence for " ^ pid); + try output_value oob_req ReqDie; flush oob_req + with e -> prerr_endline ("death sentence: " ^ Printexc.to_string e) + +(* spawn a process and read its output asynchronously *) +module Async(ML : MainLoopModel) = struct + +type process = { + cin : in_channel; + cout : out_channel; + oob_resp : in_channel; + oob_req : out_channel; + gchan : ML.async_chan; + pid : int; + mutable watch : ML.watch_id option; + mutable alive : bool; +} + +type callback = ML.condition list -> read_all:(unit -> string) -> bool +type handle = process + +let is_alive p = p.alive +let uid { pid; } = string_of_int pid +let unixpid { pid; } = pid + +let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) = + p.alive <- false; + if not alive then prerr_endline "This process is already dead" + else begin try + Option.iter ML.remove_watch watch; + output_death_sentence (uid p) oob_req; + close_in_noerr cin; + close_out_noerr cout; + if Sys.os_type = "Unix" then Unix.kill unixpid 9; + p.watch <- None + with e -> prerr_endline ("kill: "^Printexc.to_string e) end + +let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) + prog args callback += + let pid, oob_resp, oob_req, cin, cout, main, is_sock = + spawn_with_control prefer_sock env prog args in + Unix.set_nonblock main; + let gchan = + if is_sock then ML.async_chan_of_socket main + else ML.async_chan_of_file main in + let alive, watch = true, None in + let p = { cin; cout; gchan; pid; oob_resp; oob_req; alive; watch } in + p.watch <- Some ( + ML.add_watch ~callback:(fun cl -> + try + let live = callback cl ~read_all:(fun () -> ML.read_all gchan) in + if not live then kill p; + live + with e when Errors.noncritical e -> + pr_err ("Async reader raised: " ^ (Printexc.to_string e)); + kill p; + false) gchan + ); + p, cout + +let stats { oob_req; oob_resp; alive } = + assert_ alive "This process is dead"; + output_value oob_req ReqStats; + flush oob_req; + input_value oob_resp + +let rec wait p = + try snd (Unix.waitpid [] p.pid) + with + | Unix.Unix_error (Unix.EINTR, _, _) -> wait p + | Unix.Unix_error _ -> Unix.WEXITED 0o400 + +end + +module Sync(T : Empty) = struct + +type process = { + cin : in_channel; + cout : out_channel; + oob_resp : in_channel; + oob_req : out_channel; + pid : int; + mutable alive : bool; +} + +type handle = process + +let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) prog args = + let pid, oob_resp, oob_req, cin, cout, _, _ = + spawn_with_control prefer_sock env prog args in + { cin; cout; pid; oob_resp; oob_req; alive = true }, cin, cout + +let is_alive p = p.alive +let uid { pid; } = string_of_int pid +let unixpid { pid = pid; } = pid + +let kill ({ pid = unixpid; oob_req; cin; cout; alive } as p) = + p.alive <- false; + if not alive then prerr_endline "This process is already dead" + else begin try + output_death_sentence (uid p) oob_req; + close_in_noerr cin; + close_out_noerr cout; + if Sys.os_type = "Unix" then Unix.kill unixpid 9; + with e -> prerr_endline ("kill: "^Printexc.to_string e) end + +let stats { oob_req; oob_resp; alive } = + assert_ alive "This process is dead"; + output_value oob_req ReqStats; + flush oob_req; + let RespStats g = input_value oob_resp in g + +let wait { pid = unixpid } = + try snd (Unix.waitpid [] unixpid) + with Unix.Unix_error _ -> Unix.WEXITED 0o400 + +end diff --git a/lib/spawn.mli b/lib/spawn.mli new file mode 100644 index 00000000..8022573b --- /dev/null +++ b/lib/spawn.mli @@ -0,0 +1,81 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This module implements spawning/killing managed processes with a + * synchronous or asynchronous comunication channel that works with + * threads or with a glib like main loop model. + * + * This module requires no threads and no main loop model. It takes care + * of using the fastest communication channel given the underlying OS and + * the requested kind of communication. + * + * The spawned process must use the Spawned module to init its communication + * channels. + *) + +(* This is the control panel for managed processes *) +module type Control = sig + type handle + + val kill : handle -> unit + val stats : handle -> Gc.stat + val wait : handle -> Unix.process_status + val unixpid : handle -> int + + (* What is used in debug messages *) + val uid : handle -> string + + val is_alive : handle -> bool +end + +(* Abstraction to work with both threads and main loop models *) +module type Empty = sig end + +module type MainLoopModel = sig + type async_chan + type condition + type watch_id + + val add_watch : callback:(condition list -> bool) -> async_chan -> watch_id + val remove_watch : watch_id -> unit + val read_all : async_chan -> string + val async_chan_of_file : Unix.file_descr -> async_chan + val async_chan_of_socket : Unix.file_descr -> async_chan +end + +(* spawn a process and read its output asynchronously *) +module Async(ML : MainLoopModel) : sig + type process + + (* If the returned value is false the callback is never called again and + * the process is killed *) + type callback = ML.condition list -> read_all:(unit -> string) -> bool + + val spawn : + ?prefer_sock:bool -> ?env:string array -> string -> string array -> + callback -> process * out_channel + + include Control with type handle = process +end + +(* spawn a process and read its output synchronously *) +module Sync(T : Empty) : sig + type process + + val spawn : + ?prefer_sock:bool -> ?env:string array -> string -> string array -> + process * in_channel * out_channel + + include Control with type handle = process +end + +(* This is exported to separate the Spawned module, that for simplicity assumes + * Threads so it is in a separate file *) +type req = ReqDie | ReqStats | Hello of int * int +val proto_version : int +type resp = RespStats of Gc.stat diff --git a/lib/stateid.ml b/lib/stateid.ml new file mode 100644 index 00000000..59cf206e --- /dev/null +++ b/lib/stateid.ml @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype + +type t = int +let initial = 1 +let dummy = 0 +let fresh, in_range = + let cur = ref initial in + (fun () -> incr cur; !cur), (fun id -> id >= 0 && id <= !cur) +let to_string = string_of_int +let of_int id = assert(in_range id); id +let to_int id = id +let newer_than id1 id2 = id1 > id2 + +let of_xml = function + | Element ("state_id",["val",i],[]) -> + let id = int_of_string i in + (* Coqide too to parse ids too, but cannot check if they are valid. + * Hence we check for validity only if we are an ide slave. *) + if !Flags.ide_slave then assert(in_range id); + id + | _ -> raise (Invalid_argument "to_state_id") +let to_xml i = Element ("state_id",["val",string_of_int i],[]) + +let state_id_info : (t * t) Exninfo.t = Exninfo.make () +let add exn ?(valid = initial) id = + Exninfo.add exn state_id_info (valid, id) +let get exn = Exninfo.get exn state_id_info + +let equal = Int.equal +let compare = Int.compare + +module Set = Set.Make(struct type t = int let compare = compare end) + +type ('a,'b) request = { + exn_info : t * t; + stop : t; + document : 'b; + loc : Loc.t; + uuid : 'a; + name : string +} + diff --git a/lib/stateid.mli b/lib/stateid.mli new file mode 100644 index 00000000..2c12c30c --- /dev/null +++ b/lib/stateid.mli @@ -0,0 +1,45 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype + +type t + +val equal : t -> t -> bool +val compare : t -> t -> int + +module Set : Set.S with type elt = t + +val initial : t +val dummy : t +val fresh : unit -> t +val to_string : t -> string +val of_int : int -> t +val to_int : t -> int +val newer_than : t -> t -> bool + +(* XML marshalling *) +val to_xml : t -> xml +val of_xml : xml -> t + +(* Attaches to an exception the concerned state id, plus an optional + * state id that is a valid state id before the error. + * Backtracking to the valid id is safe. + * The initial_state_id is assumed to be safe. *) +val add : Exninfo.info -> ?valid:t -> t -> Exninfo.info +val get : Exninfo.info -> (t * t) option + +type ('a,'b) request = { + exn_info : t * t; + stop : t; + document : 'b; + loc : Loc.t; + uuid : 'a; + name : string +} + diff --git a/lib/store.ml b/lib/store.ml index 28eb65c8..a1788f7d 100644 --- a/lib/store.ml +++ b/lib/store.ml @@ -6,56 +6,86 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*** This module implements an "untyped store", in this particular case we - see it as an extensible record whose fields are left unspecified. ***) +(** This module implements an "untyped store", in this particular case + we see it as an extensible record whose fields are left + unspecified. ***) -(* We give a short implementation of a universal type. This is mostly equivalent - to what is proposed by module Dyn.ml, except that it requires no explicit tag. *) -module type Universal = sig - type t - - type 'a etype = { - put : 'a -> t ; - get : t -> 'a option - } +(** We use a dynamic "name" allocator. But if we needed to serialise + stores, we might want something static to avoid troubles with + plugins order. *) - val embed : unit -> 'a etype +module type T = +sig end -(* We use a dynamic "name" allocator. But if we needed to serialise stores, we -might want something static to avoid troubles with plugins order. *) +module type S = +sig + type t + type 'a field + val empty : t + val set : t -> 'a field -> 'a -> t + val get : t -> 'a field -> 'a option + val remove : t -> 'a field -> t + val merge : t -> t -> t + val field : unit -> 'a field +end -let next = - let count = ref 0 in fun () -> - let n = !count in - incr count; - n +module Make (M : T) : S = +struct -type t = Obj.t Util.Intmap.t + let next = + let count = ref 0 in fun () -> + let n = !count in + incr count; + n -module Field = struct - type 'a field = { - set : 'a -> t -> t ; - get : t -> 'a option ; - remove : t -> t - } - type 'a t = 'a field -end + type t = Obj.t option array + (** Store are represented as arrays. For small values, which is typicial, + is slightly quicker than other implementations. *) + +type 'a field = int + +let allocate len : t = Array.make len None + +let empty : t = [||] -open Field - -let empty = Util.Intmap.empty - -let field () = - let fid = next () in - let set a s = - Util.Intmap.add fid (Obj.repr a) s - in - let get s = - try Some (Obj.obj (Util.Intmap.find fid s)) - with Not_found -> None - in - let remove s = - Util.Intmap.remove fid s - in - { set = set ; get = get ; remove = remove } +let set (s : t) (i : 'a field) (v : 'a) : t = + let len = Array.length s in + let nlen = if i < len then len else succ i in + let () = assert (0 <= i) in + let ans = allocate nlen in + Array.blit s 0 ans 0 len; + Array.unsafe_set ans i (Some (Obj.repr v)); + ans + +let get (s : t) (i : 'a field) : 'a option = + let len = Array.length s in + if len <= i then None + else Obj.magic (Array.unsafe_get s i) + +let remove (s : t) (i : 'a field) = + let len = Array.length s in + let () = assert (0 <= i) in + let ans = allocate len in + Array.blit s 0 ans 0 len; + if i < len then Array.unsafe_set ans i None; + ans + +let merge (s1 : t) (s2 : t) : t = + let len1 = Array.length s1 in + let len2 = Array.length s2 in + let nlen = if len1 < len2 then len2 else len1 in + let ans = allocate nlen in + (** Important: No more allocation from here. *) + Array.blit s2 0 ans 0 len2; + for i = 0 to pred len1 do + let v = Array.unsafe_get s1 i in + match v with + | None -> () + | Some _ -> Array.unsafe_set ans i v + done; + ans + +let field () = next () + +end diff --git a/lib/store.mli b/lib/store.mli index 5df0c99a..8eab314e 100644 --- a/lib/store.mli +++ b/lib/store.mli @@ -9,17 +9,38 @@ (*** This module implements an "untyped store", in this particular case we see it as an extensible record whose fields are left unspecified. ***) -type t - -module Field : sig - type 'a field = { - set : 'a -> t -> t ; - get : t -> 'a option ; - remove : t -> t - } - type 'a t = 'a field +module type T = +sig +(** FIXME: Waiting for first-class modules... *) end -val empty : t +module type S = +sig + type t + (** Type of stores *) -val field : unit -> 'a Field.field + type 'a field + (** Type of field of such stores *) + + val empty : t + (** Empty store *) + + val set : t -> 'a field -> 'a -> t + (** Set a field *) + + val get : t -> 'a field -> 'a option + (** Get the value of a field, if any *) + + val remove : t -> 'a field -> t + (** Unset the value of the field *) + + val merge : t -> t -> t + (** [merge s1 s2] adds all the fields of [s1] into [s2]. *) + + val field : unit -> 'a field + (** Create a new field *) + +end + +module Make (M : T) : S +(** Create a new store type. *) diff --git a/lib/system.ml b/lib/system.ml index 8f436366..73095f9c 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,126 +9,10 @@ (* $Id$ *) open Pp +open Errors open Util open Unix -(* Expanding shell variables and home-directories *) - -let safe_getenv_def var def = - try - Sys.getenv var - with Not_found -> - warning ("Environment variable "^var^" not found: using '"^def^"' ."); - flush_all (); - def - -let getenv_else s dft = try Sys.getenv s with Not_found -> dft - -(* On win32, the home directory is probably not in $HOME, but in - some other environment variable *) - -let home = - try Sys.getenv "HOME" with Not_found -> - try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> - try Sys.getenv "USERPROFILE" with Not_found -> - warning ("Cannot determine user home directory, using '.' ."); - flush_all (); - Filename.current_dir_name - -let safe_getenv n = safe_getenv_def n ("$"^n) - -let rec expand_atom s i = - let l = String.length s in - if i<l && (is_digit s.[i] or is_letter s.[i] or s.[i] = '_') - then expand_atom s (i+1) - else i - -let rec expand_macros s i = - let l = String.length s in - if i=l then s else - match s.[i] with - | '$' -> - let n = expand_atom s (i+1) in - let v = safe_getenv (String.sub s (i+1) (n-i-1)) in - let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in - expand_macros s (i + String.length v) - | '~' when i = 0 -> - let n = expand_atom s (i+1) in - let v = - if n=i+1 then home - else (getpwnam (String.sub s (i+1) (n-i-1))).pw_dir - in - let s = v^(String.sub s n (l-n)) in - expand_macros s (String.length v) - | c -> expand_macros s (i+1) - -let expand_path_macros s = expand_macros s 0 - -(* Files and load path. *) - -type physical_path = string -type load_path = physical_path list - -let physical_path_of_string s = s -let string_of_physical_path p = p - -(* - * Split a path into a list of directories. A one-liner with Str, but Coq - * doesn't seem to use this library at all, so here is a slighly longer version. - *) - -let lpath_from_path path path_separator = - let n = String.length path in - let rec aux i l = - if i < n then - let j = - try String.index_from path i path_separator - with Not_found -> n - in - let dir = String.sub path i (j-i) in - aux (j+1) (dir::l) - else - l - in List.rev (aux 0 []) - -(* Hints to partially detects if two paths refer to the same repertory *) -let rec remove_path_dot p = - let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) - let n = String.length curdir in - let l = String.length p in - if l > n && String.sub p 0 n = curdir then - let n' = - let sl = String.length Filename.dir_sep in - let i = ref n in - while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in - remove_path_dot (String.sub p n' (l - n')) - else - p - -let strip_path p = - let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) - let n = String.length cwd in - let l = String.length p in - if l > n && String.sub p 0 n = cwd then - let n' = - let sl = String.length Filename.dir_sep in - let i = ref n in - while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in - remove_path_dot (String.sub p n' (l - n')) - else - remove_path_dot p - -let canonical_path_name p = - let current = Sys.getcwd () in - try - Sys.chdir p; - let p' = Sys.getcwd () in - Sys.chdir current; - p' - with Sys_error _ -> - (* We give up to find a canonical name and just simplify it... *) - strip_path p - (* All subdirectories, recursively *) let exists_dir dir = @@ -139,9 +23,9 @@ let skipped_dirnames = ref ["CVS"; "_darcs"] let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames let ok_dirname f = - f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) && - try ignore (check_ident f); true - with e when e <> Sys.Break -> false + not (String.is_empty f) && f.[0] != '.' && + not (String.List.mem f !skipped_dirnames) && + (match Unicode.ident_refutation f with None -> true | _ -> false) let all_subdirs ~unix_path:root = let l = ref [] in @@ -154,11 +38,13 @@ let all_subdirs ~unix_path:root = if ok_dirname f then let file = Filename.concat dir f in try - if (stat file).st_kind = S_DIR then begin - let newrel = rel@[f] in + begin match (stat file).st_kind with + | S_DIR -> + let newrel = rel @ [f] in add file newrel; traverse file newrel - end + | _ -> () + end with Unix_error (e,s1,s2) -> () done with End_of_file -> @@ -167,28 +53,43 @@ let all_subdirs ~unix_path:root = if exists_dir root then traverse root []; List.rev !l +let rec search paths test = + match paths with + | [] -> [] + | lpe :: rem -> test lpe @ search rem test + let where_in_path ?(warn=true) path filename = - let rec search = function - | lpe :: rem -> - let f = Filename.concat lpe filename in - if Sys.file_exists f - then (lpe,f) :: search rem - else search rem - | [] -> [] in - let rec check_and_warn l = - match l with - | [] -> raise Not_found - | (lpe, f) :: l' -> - if warn & l' <> [] then - msg_warning - (str filename ++ str " has been found in" ++ spc () ++ - hov 0 (str "[ " ++ - hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon()) - (fun (lpe,_) -> str lpe) l) - ++ str " ];") ++ fnl () ++ - str "loading " ++ str f); - (lpe, f) in - check_and_warn (search path) + let check_and_warn l = match l with + | [] -> raise Not_found + | (lpe, f) :: l' -> + let () = match l' with + | _ :: _ when warn -> + msg_warning + (str filename ++ str " has been found in" ++ spc () ++ + hov 0 (str "[ " ++ + hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon()) + (fun (lpe,_) -> str lpe) l) + ++ str " ];") ++ fnl () ++ + str "loading " ++ str f) + | _ -> () + in + (lpe, f) + in + check_and_warn (search path (fun lpe -> + let f = Filename.concat lpe filename in + if Sys.file_exists f then [lpe,f] else [])) + +let where_in_path_rex path rex = + search path (fun lpe -> + try + let files = Sys.readdir lpe in + CList.map_filter (fun name -> + try + ignore(Str.search_forward rex name 0); + Some (lpe,Filename.concat lpe name) + with Not_found -> None) + (Array.to_list files) + with Sys_error _ -> []) let find_file_in_path ?(warn=true) paths filename = if not (Filename.is_implicit filename) then @@ -209,56 +110,87 @@ let is_in_path lpath filename = try ignore (where_in_path ~warn:false lpath filename); true with Not_found -> false -let path_separator = if Sys.os_type = "Unix" then ':' else ';' - let is_in_system_path filename = - let path = try Sys.getenv "PATH" + let path = try Sys.getenv "PATH" with Not_found -> error "system variable PATH not found" in - let lpath = lpath_from_path path path_separator in + let lpath = CUnix.path_to_list path in is_in_path lpath filename -let make_suffix name suffix = - if Filename.check_suffix name suffix then name else (name ^ suffix) - -let file_readable_p name = - try access name [R_OK];true with Unix_error (_, _, _) -> false - let open_trapping_failure name = try open_out_bin name - with e when e <> Sys.Break -> error ("Can't open " ^ name) + with e when Errors.noncritical e -> error ("Can't open " ^ name) let try_remove filename = try Sys.remove filename - with e when e <> Sys.Break -> - msgnl (str"Warning: " ++ str"Could not remove file " ++ - str filename ++ str" which is corrupted!" ) + with e when Errors.noncritical e -> + msg_warning + (str"Could not remove file " ++ str filename ++ str" which is corrupted!") -let marshal_out ch v = Marshal.to_channel ch v [] +let error_corrupted file s = error (file ^": " ^ s ^ ". Try to rebuild it.") + +let input_binary_int f ch = + try input_binary_int ch + with + | End_of_file -> error_corrupted f "premature end of file" + | Failure s -> error_corrupted f s +let output_binary_int ch x = output_binary_int ch x; flush ch + +let marshal_out ch v = Marshal.to_channel ch v []; flush ch let marshal_in filename ch = try Marshal.from_channel ch with - | End_of_file -> error "corrupted file: reached end of file" - | Failure _ (* e.g. "truncated object" *) -> - error (filename ^ " is corrupted, try to rebuild it.") + | End_of_file -> error_corrupted filename "premature end of file" + | Failure s -> error_corrupted filename s + +let digest_out = Digest.output +let digest_in filename ch = + try Digest.input ch + with + | End_of_file -> error_corrupted filename "premature end of file" + | Failure s -> error_corrupted filename s + +let marshal_out_segment f ch v = + let start = pos_out ch in + output_binary_int ch 0; (* dummy value for stop *) + marshal_out ch v; + let stop = pos_out ch in + seek_out ch start; + output_binary_int ch stop; + seek_out ch stop; + digest_out ch (Digest.file f) + +let marshal_in_segment f ch = + let stop = (input_binary_int f ch : int) in + let v = marshal_in f ch in + let digest = digest_in f ch in + v, stop, digest + +let skip_in_segment f ch = + let stop = (input_binary_int f ch : int) in + seek_in ch stop; + stop, digest_in f ch exception Bad_magic_number of string -let raw_extern_intern magic suffix = - let extern_state name = - let filename = make_suffix name suffix in +let raw_extern_intern magic = + let extern_state filename = let channel = open_trapping_failure filename in output_binary_int channel magic; - filename,channel + filename, channel and intern_state filename = - let channel = open_in_bin filename in - if input_binary_int channel <> magic then - raise (Bad_magic_number filename); - channel + try + let channel = open_in_bin filename in + if not (Int.equal (input_binary_int filename channel) magic) then + raise (Bad_magic_number filename); + channel + with + | End_of_file -> error_corrupted filename "premature end of file" + | Failure s | Sys_error s -> error_corrupted filename s in (extern_state,intern_state) -let extern_intern ?(warn=true) magic suffix = - let (raw_extern,raw_intern) = raw_extern_intern magic suffix in +let extern_intern ?(warn=true) magic = + let (raw_extern,raw_intern) = raw_extern_intern magic in let extern_state name val_0 = try let (filename,channel) = raw_extern name in @@ -266,11 +198,13 @@ let extern_intern ?(warn=true) magic suffix = marshal_out channel val_0; close_out channel with reraise -> - begin try_remove filename; raise reraise end + let reraise = Errors.push reraise in + let () = try_remove filename in + iraise reraise with Sys_error s -> error ("System error: " ^ s) and intern_state paths name = try - let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in + let _,filename = find_file_in_path ~warn paths name in let channel = raw_intern filename in let v = marshal_in filename channel in close_in channel; @@ -284,79 +218,47 @@ let with_magic_number_check f a = try f a with Bad_magic_number fname -> errorlabstrm "with_magic_number_check" - (str"File " ++ str fname ++ strbrk" has bad magic number." ++ spc () ++ + (str"File " ++ str fname ++ strbrk" has bad magic number." ++ spc () ++ strbrk "It is corrupted or was compiled with another version of Coq.") -(* Communication through files with another executable *) - -let connect writefun readfun com = - let name = Filename.basename com in - let tmp_to = Filename.temp_file ("coq-"^name^"-in") ".xml" in - let tmp_from = Filename.temp_file ("coq-"^name^"-out") ".xml" in - let ch_to_in,ch_to_out = - try open_in tmp_to, open_out tmp_to - with Sys_error s -> error ("Cannot set connection to "^com^"("^s^")") in - let ch_from_in,ch_from_out = - try open_in tmp_from, open_out tmp_from - with Sys_error s -> - close_out ch_to_out; close_in ch_to_in; - error ("Cannot set connection from "^com^"("^s^")") in - writefun ch_to_out; - close_out ch_to_out; - let pid = - let ch_to' = Unix.descr_of_in_channel ch_to_in in - let ch_from' = Unix.descr_of_out_channel ch_from_out in - try Unix.create_process com [|com|] ch_to' ch_from' Unix.stdout - with Unix.Unix_error (err,_,_) -> - close_in ch_to_in; close_in ch_from_in; close_out ch_from_out; - unlink tmp_from; unlink tmp_to; - error ("Cannot execute "^com^"("^(Unix.error_message err)^")") in - close_in ch_to_in; - close_out ch_from_out; - (match snd (Unix.waitpid [] pid) with - | Unix.WEXITED 127 -> error (com^": cannot execute") - | Unix.WEXITED 0 -> () - | _ -> error (com^" exited abnormally")); - let a = readfun ch_from_in in - close_in ch_from_in; - unlink tmp_from; - unlink tmp_to; - a - -let run_command converter f c = - let result = Buffer.create 127 in - let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in - let buff = String.make 127 ' ' in - let buffe = String.make 127 ' ' in - let n = ref 0 in - let ne = ref 0 in - - while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; - !n+ !ne <> 0 - do - let r = converter (String.sub buff 0 !n) in - f r; - Buffer.add_string result r; - let r = converter (String.sub buffe 0 !ne) in - f r; - Buffer.add_string result r - done; - (Unix.close_process_full (cin,cout,cerr), Buffer.contents result) - (* Time stamps. *) type time = float * float * float let get_time () = - let t = times () in - (time(), t.tms_utime, t.tms_stime) + let t = Unix.times () in + (Unix.gettimeofday(), t.tms_utime, t.tms_stime) -let time_difference (t1,_,_) (t2,_,_) = t2 -. t1 +(* Keep only 3 significant digits *) +let round f = (floor (f *. 1e3)) *. 1e-3 + +let time_difference (t1,_,_) (t2,_,_) = round (t2 -. t1) let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) = - real (stopreal -. startreal) ++ str " secs " ++ + real (round (stopreal -. startreal)) ++ str " secs " ++ str "(" ++ - real ((-.) ustop ustart) ++ str "u" ++ + real (round (ustop -. ustart)) ++ str "u" ++ str "," ++ - real ((-.) sstop sstart) ++ str "s" ++ + real (round (sstop -. sstart)) ++ str "s" ++ str ")" + +let with_time time f x = + let tstart = get_time() in + let msg = if time then "" else "Finished transaction in " in + try + let y = f x in + let tend = get_time() in + let msg2 = if time then "" else " (successful)" in + msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + y + with e -> + let tend = get_time() in + let msg = if time then "" else "Finished failing transaction in " in + let msg2 = if time then "" else " (failure)" in + msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + raise e + +let process_id () = + if Flags.async_proofs_is_worker () then !Flags.async_proofs_worker_id + else Printf.sprintf "master:%d" (Thread.id (Thread.self ())) + diff --git a/lib/system.mli b/lib/system.mli index b56e65a4..a3d66d57 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** System utilities *) +(** {5 Coqtop specific system utilities} *) (** {6 Files and load paths} *) @@ -14,63 +14,50 @@ given by the user. For efficiency, we keep the full path (field [directory]), the root path and the path relative to the root. *) -type physical_path = string -type load_path = physical_path list - -val canonical_path_name : string -> string - val exclude_search_in_dirname : string -> unit -val all_subdirs : unix_path:string -> (physical_path * string list) list -val is_in_path : load_path -> string -> bool +val all_subdirs : unix_path:string -> (CUnix.physical_path * string list) list +val is_in_path : CUnix.load_path -> string -> bool val is_in_system_path : string -> bool -val where_in_path : ?warn:bool -> load_path -> string -> physical_path * string - -val physical_path_of_string : string -> physical_path -val string_of_physical_path : physical_path -> string - -val make_suffix : string -> string -> string -val file_readable_p : string -> bool - -val expand_path_macros : string -> string -val getenv_else : string -> string -> string -val home : string +val where_in_path : + ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string +val where_in_path_rex : + CUnix.load_path -> Str.regexp -> (CUnix.physical_path * string) list val exists_dir : string -> bool val find_file_in_path : - ?warn:bool -> load_path -> string -> physical_path * string + ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string (** {6 I/O functions } *) (** Generic input and output functions, parameterized by a magic number and a suffix. The intern functions raise the exception [Bad_magic_number] when the check fails, with the full file name. *) -val marshal_out : out_channel -> 'a -> unit -val marshal_in : string -> in_channel -> 'a - exception Bad_magic_number of string -val raw_extern_intern : int -> string -> +val raw_extern_intern : int -> (string -> string * out_channel) * (string -> in_channel) -val extern_intern : ?warn:bool -> int -> string -> - (string -> 'a -> unit) * (load_path -> string -> 'a) +val extern_intern : ?warn:bool -> int -> + (string -> 'a -> unit) * (CUnix.load_path -> string -> 'a) val with_magic_number_check : ('a -> 'b) -> 'a -> 'b -(** {6 Sending/receiving once with external executable } *) +(** Clones of Marshal.to_channel (with flush) and + Marshal.from_channel (with nice error message) *) + +val marshal_out : out_channel -> 'a -> unit +val marshal_in : string -> in_channel -> 'a -val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a +(** Clones of Digest.output and Digest.input (with nice error message) *) -(** {6 Executing commands } *) -(** [run_command converter f com] launches command [com], and returns - the contents of stdout and stderr that have been processed with - [converter]; the processed contents of stdout and stderr is also - passed to [f] *) +val digest_out : out_channel -> Digest.t -> unit +val digest_in : string -> in_channel -> Digest.t -val run_command : (string -> string) -> (string -> unit) -> string -> - Unix.process_status * string +val marshal_out_segment : string -> out_channel -> 'a -> unit +val marshal_in_segment : string -> in_channel -> 'a * int * Digest.t +val skip_in_segment : string -> in_channel -> int * Digest.t (** {6 Time stamps.} *) @@ -79,3 +66,8 @@ type time val get_time : unit -> time val time_difference : time -> time -> float (** in seconds *) val fmt_time_difference : time -> time -> Pp.std_ppcmds + +val with_time : bool -> ('a -> 'b) -> 'a -> 'b + +(** {6 Name of current process.} *) +val process_id : unit -> string diff --git a/lib/terminal.ml b/lib/terminal.ml new file mode 100644 index 00000000..1e6c2557 --- /dev/null +++ b/lib/terminal.ml @@ -0,0 +1,284 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type color = [ + `DEFAULT +| `BLACK +| `RED +| `GREEN +| `YELLOW +| `BLUE +| `MAGENTA +| `CYAN +| `WHITE +| `LIGHT_BLACK +| `LIGHT_RED +| `LIGHT_GREEN +| `LIGHT_YELLOW +| `LIGHT_BLUE +| `LIGHT_MAGENTA +| `LIGHT_CYAN +| `LIGHT_WHITE +| `INDEX of int +| `RGB of (int * int * int) +] + +type style = { + fg_color : color option; + bg_color : color option; + bold : bool option; + italic : bool option; + underline : bool option; + negative : bool option; +} + +let set o1 o2 = match o1 with +| None -> o2 +| Some _ -> + match o2 with + | None -> o1 + | Some _ -> o2 + +let default = { + fg_color = None; + bg_color = None; + bold = None; + italic = None; + underline = None; + negative = None; +} + +let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style () = + let st = match style with + | None -> default + | Some st -> st + in + { + fg_color = set st.fg_color fg_color; + bg_color = set st.bg_color bg_color; + bold = set st.bold bold; + italic = set st.italic italic; + underline = set st.underline underline; + negative = set st.negative negative; + } + +let merge s1 s2 = + { + fg_color = set s1.fg_color s2.fg_color; + bg_color = set s1.bg_color s2.bg_color; + bold = set s1.bold s2.bold; + italic = set s1.italic s2.italic; + underline = set s1.underline s2.underline; + negative = set s1.negative s2.negative; + } + +let base_color = function +| `DEFAULT -> 9 +| `BLACK -> 0 +| `RED -> 1 +| `GREEN -> 2 +| `YELLOW -> 3 +| `BLUE -> 4 +| `MAGENTA -> 5 +| `CYAN -> 6 +| `WHITE -> 7 +| `LIGHT_BLACK -> 0 +| `LIGHT_RED -> 1 +| `LIGHT_GREEN -> 2 +| `LIGHT_YELLOW -> 3 +| `LIGHT_BLUE -> 4 +| `LIGHT_MAGENTA -> 5 +| `LIGHT_CYAN -> 6 +| `LIGHT_WHITE -> 7 +| _ -> invalid_arg "base_color" + +let extended_color off = function +| `INDEX i -> [off + 8; 5; i] +| `RGB (r, g, b) -> [off + 8; 2; r; g; b] +| _ -> invalid_arg "extended_color" + +let is_light = function +| `LIGHT_BLACK +| `LIGHT_RED +| `LIGHT_GREEN +| `LIGHT_YELLOW +| `LIGHT_BLUE +| `LIGHT_MAGENTA +| `LIGHT_CYAN +| `LIGHT_WHITE -> true +| _ -> false + +let is_extended = function +| `INDEX _ | `RGB _ -> true +| _ -> false + +let eval st = + let fg = match st.fg_color with + | None -> [] + | Some c -> + if is_light c then [90 + base_color c] + else if is_extended c then extended_color 30 c + else [30 + base_color c] + in + let bg = match st.bg_color with + | None -> [] + | Some c -> + if is_light c then [100 + base_color c] + else if is_extended c then extended_color 40 c + else [40 + base_color c] + in + let bold = match st.bold with + | None -> [] + | Some true -> [1] + | Some false -> [22] + in + let italic = match st.italic with + | None -> [] + | Some true -> [3] + | Some false -> [23] + in + let underline = match st.underline with + | None -> [] + | Some true -> [4] + | Some false -> [24] + in + let negative = match st.negative with + | None -> [] + | Some true -> [7] + | Some false -> [27] + in + let tags = fg @ bg @ bold @ italic @ underline @ negative in + let tags = List.map string_of_int tags in + Printf.sprintf "\027[%sm" (String.concat ";" tags) + +let reset = "\027[0m" + +let reset_style = { + fg_color = Some `DEFAULT; + bg_color = Some `DEFAULT; + bold = Some false; + italic = Some false; + underline = Some false; + negative = Some false; +} + +let has_style t = Unix.isatty t + +let split c s = + let len = String.length s in + let rec split n = + try + let pos = String.index_from s n c in + let dir = String.sub s n (pos-n) in + dir :: split (succ pos) + with + | Not_found -> [String.sub s n (len-n)] + in + if len = 0 then [] else split 0 + +let check_char i = if i < 0 || i > 255 then invalid_arg "check_char" + +let parse_color off rem = match off with +| 0 -> (`BLACK, rem) +| 1 -> (`RED, rem) +| 2 -> (`GREEN, rem) +| 3 -> (`YELLOW, rem) +| 4 -> (`BLUE, rem) +| 5 -> (`MAGENTA, rem) +| 6 -> (`CYAN, rem) +| 7 -> (`WHITE, rem) +| 9 -> (`DEFAULT, rem) +| 8 -> + begin match rem with + | 5 :: i :: rem -> + check_char i; + (`INDEX i, rem) + | 2 :: r :: g :: b :: rem -> + check_char r; + check_char g; + check_char b; + (`RGB (r, g, b), rem) + | _ -> invalid_arg "parse_color" + end +| _ -> invalid_arg "parse_color" + +let set_light = function +| `BLACK -> `LIGHT_BLACK +| `RED -> `LIGHT_RED +| `GREEN -> `LIGHT_GREEN +| `YELLOW -> `LIGHT_YELLOW +| `BLUE -> `LIGHT_BLUE +| `MAGENTA -> `LIGHT_MAGENTA +| `CYAN -> `LIGHT_CYAN +| `WHITE -> `LIGHT_WHITE +| _ -> invalid_arg "parse_color" + +let rec parse_style style = function +| [] -> style +| 0 :: rem -> + let style = merge style reset_style in + parse_style style rem +| 1 :: rem -> + let style = make ~style ~bold:true () in + parse_style style rem +| 3 :: rem -> + let style = make ~style ~italic:true () in + parse_style style rem +| 4 :: rem -> + let style = make ~style ~underline:true () in + parse_style style rem +| 7 :: rem -> + let style = make ~style ~negative:true () in + parse_style style rem +| 22 :: rem -> + let style = make ~style ~bold:false () in + parse_style style rem +| 23 :: rem -> + let style = make ~style ~italic:false () in + parse_style style rem +| 24 :: rem -> + let style = make ~style ~underline:false () in + parse_style style rem +| 27 :: rem -> + let style = make ~style ~negative:false () in + parse_style style rem +| code :: rem when (30 <= code && code < 40) -> + let color, rem = parse_color (code mod 10) rem in + let style = make ~style ~fg_color:color () in + parse_style style rem +| code :: rem when (40 <= code && code < 50) -> + let color, rem = parse_color (code mod 10) rem in + let style = make ~style ~bg_color:color () in + parse_style style rem +| code :: rem when (90 <= code && code < 100) -> + let color, rem = parse_color (code mod 10) rem in + let style = make ~style ~fg_color:(set_light color) () in + parse_style style rem +| code :: rem when (100 <= code && code < 110) -> + let color, rem = parse_color (code mod 10) rem in + let style = make ~style ~bg_color:(set_light color) () in + parse_style style rem +| _ :: rem -> parse_style style rem + +(** Parse LS_COLORS-like strings *) +let parse s = + let defs = split ':' s in + let fold accu s = match split '=' s with + | [name; attrs] -> + let attrs = split ';' attrs in + let accu = + try + let attrs = List.map int_of_string attrs in + let attrs = parse_style (make ()) attrs in + (name, attrs) :: accu + with _ -> accu + in + accu + | _ -> accu + in + List.fold_left fold [] defs diff --git a/lib/terminal.mli b/lib/terminal.mli new file mode 100644 index 00000000..f308ede3 --- /dev/null +++ b/lib/terminal.mli @@ -0,0 +1,61 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type color = [ + `DEFAULT +| `BLACK +| `RED +| `GREEN +| `YELLOW +| `BLUE +| `MAGENTA +| `CYAN +| `WHITE +| `LIGHT_BLACK +| `LIGHT_RED +| `LIGHT_GREEN +| `LIGHT_YELLOW +| `LIGHT_BLUE +| `LIGHT_MAGENTA +| `LIGHT_CYAN +| `LIGHT_WHITE +| `INDEX of int +| `RGB of (int * int * int) +] + +type style = { + fg_color : color option; + bg_color : color option; + bold : bool option; + italic : bool option; + underline : bool option; + negative : bool option; +} + +val make : ?fg_color:color -> ?bg_color:color -> + ?bold:bool -> ?italic:bool -> ?underline:bool -> + ?negative:bool -> ?style:style -> unit -> style +(** Create a style from the given flags. It is derived from the optional + [style] argument if given. *) + +val merge : style -> style -> style +(** [merge s1 s2] returns [s1] with all defined values of [s2] overwritten. *) + +val eval : style -> string +(** Generate an escape sequence from a style. *) + +val reset : string +(** This escape sequence resets all attributes. *) + +val has_style : Unix.file_descr -> bool +(** Whether an output file descriptor handles styles. Very heuristic, only + checks it is a terminal. *) + +val parse : string -> (string * style) list +(** Parse strings describing terminal styles in the LS_COLORS syntax. For + robustness, ignore meaningless entries and drops undefined styles. *) diff --git a/lib/trie.ml b/lib/trie.ml new file mode 100644 index 00000000..e369e6ad --- /dev/null +++ b/lib/trie.ml @@ -0,0 +1,89 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module type S = +sig + type label + type data + type t + val empty : t + val get : t -> data + val next : t -> label -> t + val labels : t -> label list + val add : label list -> data -> t -> t + val remove : label list -> data -> t -> t + val iter : (label list -> data -> unit) -> t -> unit +end + +module type Grp = +sig + type t + val nil : t + val is_nil : t -> bool + val add : t -> t -> t + val sub : t -> t -> t +end + +module Make (Y : Map.OrderedType) (X : Grp) = +struct + +module T_codom = Map.Make(Y) + +type data = X.t +type label = Y.t +type t = Node of X.t * t T_codom.t + +let codom_for_all f m = + let fold key v accu = f v && accu in + T_codom.fold fold m true + +let empty = Node (X.nil, T_codom.empty) + +let next (Node (_,m)) lbl = T_codom.find lbl m + +let get (Node (hereset,_)) = hereset + +let labels (Node (_,m)) = + (** FIXME: this is order-dependent. Try to find a more robust presentation? *) + List.rev (T_codom.fold (fun x _ acc -> x::acc) m []) + +let is_empty_node (Node(a,b)) = (X.is_nil a) && (T_codom.is_empty b) + +let assure_arc m lbl = + if T_codom.mem lbl m then + m + else + T_codom.add lbl (Node (X.nil,T_codom.empty)) m + +let cleanse_arcs (Node (hereset,m)) = + let m = if codom_for_all is_empty_node m then T_codom.empty else m in + Node(hereset, m) + +let rec at_path f (Node (hereset,m)) = function + | [] -> + cleanse_arcs (Node(f hereset,m)) + | h::t -> + let m = assure_arc m h in + cleanse_arcs (Node(hereset, + T_codom.add h (at_path f (T_codom.find h m) t) m)) + +let add path v tm = + at_path (fun hereset -> X.add v hereset) tm path + +let remove path v tm = + at_path (fun hereset -> X.sub hereset v) tm path + +let iter f tlm = + let rec apprec pfx (Node(hereset,m)) = + let path = List.rev pfx in + f path hereset; + T_codom.iter (fun l tm -> apprec (l::pfx) tm) m + in + apprec [] tlm + +end diff --git a/lib/trie.mli b/lib/trie.mli new file mode 100644 index 00000000..81847485 --- /dev/null +++ b/lib/trie.mli @@ -0,0 +1,61 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Generic functorized trie data structure. *) + +module type S = +sig + (** A trie is a generalization of the map data structure where the keys are + themselves lists. *) + + type label + (** Keys of the trie structure are [label list]. *) + + type data + (** Data on nodes of tries are finite sets of [data]. *) + + type t + (** The trie data structure. Essentially a finite map with keys [label list] + and content [data Set.t]. *) + + val empty : t + (** The empty trie. *) + + val get : t -> data + (** Get the data at the current node. *) + + val next : t -> label -> t + (** [next t lbl] returns the subtrie of [t] pointed by [lbl]. + @raise Not_found if there is none. *) + + val labels : t -> label list + (** Get the list of defined labels at the current node. *) + + val add : label list -> data -> t -> t + (** [add t path v] adds [v] at path [path] in [t]. *) + + val remove : label list -> data -> t -> t + (** [remove t path v] removes [v] from path [path] in [t]. *) + + val iter : (label list -> data -> unit) -> t -> unit + (** Apply a function to all contents. *) + +end + +module type Grp = +sig + type t + val nil : t + val is_nil : t -> bool + val add : t -> t -> t + val sub : t -> t -> t +end + +module Make (Label : Set.OrderedType) (Data : Grp) : S + with type label = Label.t and type data = Data.t +(** Generating functor, for a given type of labels and data. *) diff --git a/lib/tries.ml b/lib/tries.ml deleted file mode 100644 index 60b466b7..00000000 --- a/lib/tries.ml +++ /dev/null @@ -1,78 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - - - -module Make = - functor (X : Set.OrderedType) -> - functor (Y : Map.OrderedType) -> -struct - module T_dom = Fset.Make(X) - module T_codom = Fmap.Make(Y) - - type t = Node of T_dom.t * t T_codom.t - - let codom_to_list m = T_codom.fold (fun x y l -> (x,y)::l) m [] - - let codom_rng m = T_codom.fold (fun _ y acc -> y::acc) m [] - - let codom_dom m = T_codom.fold (fun x _ acc -> x::acc) m [] - - let empty = Node (T_dom.empty, T_codom.empty) - - let map (Node (_,m)) lbl = T_codom.find lbl m - - let xtract (Node (hereset,_)) = T_dom.elements hereset - - let dom (Node (_,m)) = codom_dom m - - let in_dom (Node (_,m)) lbl = T_codom.mem lbl m - - let is_empty_node (Node(a,b)) = (T_dom.elements a = []) & (codom_to_list b = []) - -let assure_arc m lbl = - if T_codom.mem lbl m then - m - else - T_codom.add lbl (Node (T_dom.empty,T_codom.empty)) m - -let cleanse_arcs (Node (hereset,m)) = - let l = codom_rng m in - Node(hereset, if List.for_all is_empty_node l then T_codom.empty else m) - -let rec at_path f (Node (hereset,m)) = function - | [] -> - cleanse_arcs (Node(f hereset,m)) - | h::t -> - let m = assure_arc m h in - cleanse_arcs (Node(hereset, - T_codom.add h (at_path f (T_codom.find h m) t) m)) - -let add tm (path,v) = - at_path (fun hereset -> T_dom.add v hereset) tm path - -let rmv tm (path,v) = - at_path (fun hereset -> T_dom.remove v hereset) tm path - -let app f tlm = - let rec apprec pfx (Node(hereset,m)) = - let path = List.rev pfx in - T_dom.iter (fun v -> f(path,v)) hereset; - T_codom.iter (fun l tm -> apprec (l::pfx) tm) m - in - apprec [] tlm - -let to_list tlm = - let rec torec pfx (Node(hereset,m)) = - let path = List.rev pfx in - List.flatten((List.map (fun v -> (path,v)) (T_dom.elements hereset)):: - (List.map (fun (l,tm) -> torec (l::pfx) tm) (codom_to_list m))) - in - torec [] tlm - -end diff --git a/lib/tries.mli b/lib/tries.mli deleted file mode 100644 index 8e837677..00000000 --- a/lib/tries.mli +++ /dev/null @@ -1,34 +0,0 @@ - - - - - -module Make : - functor (X : Set.OrderedType) -> - functor (Y : Map.OrderedType) -> -sig - - type t - - val empty : t - - (** Work on labels, not on paths. *) - - val map : t -> Y.t -> t - - val xtract : t -> X.t list - - val dom : t -> Y.t list - - val in_dom : t -> Y.t -> bool - - (** Work on paths, not on labels. *) - - val add : t -> Y.t list * X.t -> t - - val rmv : t -> Y.t list * X.t -> t - - val app : ((Y.t list * X.t) -> unit) -> t -> unit - - val to_list : t -> (Y.t list * X.t) list -end diff --git a/lib/unicode.ml b/lib/unicode.ml new file mode 100644 index 00000000..1765e93d --- /dev/null +++ b/lib/unicode.ml @@ -0,0 +1,241 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** Unicode utilities *) + +type status = Letter | IdentPart | Symbol + +exception Unsupported + +(* The following table stores classes of Unicode characters that + are used by the lexer. There are 3 different classes so 2 bits are + allocated for each character. We only use 16 bits over the 31 bits + to simplify the masking process. (This choice seems to be a good + trade-off between speed and space after some benchmarks.) *) + +(* A 256ko table, initially filled with zeros. *) +let table = Array.make (1 lsl 17) 0 + +(* Associate a 2-bit pattern to each status at position [i]. + Only the 3 lowest bits of [i] are taken into account to + define the position of the pattern in the word. + Notice that pattern "00" means "undefined". *) +let mask i = function + | Letter -> 1 lsl ((i land 7) lsl 1) (* 01 *) + | IdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *) + | Symbol -> 3 lsl ((i land 7) lsl 1) (* 11 *) + +(* Helper to reset 2 bits in a word. *) +let reset_mask i = + lnot (3 lsl ((i land 7) lsl 1)) + +(* Initialize the lookup table from a list of segments, assigning + a status to every character of each segment. The order of these + assignments is relevant: it is possible to assign status [s] to + a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is + between [c1] and [c2]. *) +let mk_lookup_table_from_unicode_tables_for status tables = + List.iter + (List.iter + (fun (c1, c2) -> + for i = c1 to c2 do + table.(i lsr 3) <- + (table.(i lsr 3) land (reset_mask i)) lor (mask i status) + done)) + tables + +(* Look up into the table and interpret the found pattern. *) +let lookup x = + let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in + if v = 1 then Letter + else if v = 2 then IdentPart + else if v = 3 then Symbol + else raise Unsupported + +(* [classify] discriminates between 3 different kinds of + symbols based on the standard unicode classification (extracted from + Camomile). *) +let classify = + let single c = [ (c, c) ] in + (* General tables. *) + mk_lookup_table_from_unicode_tables_for Symbol + [ + Unicodetable.sm; (* Symbol, maths. *) + Unicodetable.sc; (* Symbol, currency. *) + Unicodetable.so; (* Symbol, modifier. *) + Unicodetable.pd; (* Punctation, dash. *) + Unicodetable.pc; (* Punctation, connector. *) + Unicodetable.pe; (* Punctation, open. *) + Unicodetable.ps; (* Punctation, close. *) + Unicodetable.pi; (* Punctation, initial quote. *) + Unicodetable.pf; (* Punctation, final quote. *) + Unicodetable.po; (* Punctation, other. *) + ]; + mk_lookup_table_from_unicode_tables_for Letter + [ + Unicodetable.lu; (* Letter, uppercase. *) + Unicodetable.ll; (* Letter, lowercase. *) + Unicodetable.lt; (* Letter, titlecase. *) + Unicodetable.lo; (* Letter, others. *) + ]; + mk_lookup_table_from_unicode_tables_for IdentPart + [ + Unicodetable.nd; (* Number, decimal digits. *) + Unicodetable.nl; (* Number, letter. *) + Unicodetable.no; (* Number, other. *) + ]; + + (* Workaround. Some characters seems to be missing in + Camomile's category tables. We add them manually. *) + mk_lookup_table_from_unicode_tables_for Letter + [ + [(0x01D00, 0x01D7F)]; (* Phonetic Extensions. *) + [(0x01D80, 0x01DBF)]; (* Phonetic Extensions Suppl. *) + [(0x01DC0, 0x01DFF)]; (* Combining Diacritical Marks Suppl.*) + ]; + + (* Exceptions (from a previous version of this function). *) + mk_lookup_table_from_unicode_tables_for Symbol + [ + [(0x000B2, 0x000B3)]; (* Superscript 2-3. *) + single 0x000B9; (* Superscript 1. *) + single 0x02070; (* Superscript 0. *) + [(0x02074, 0x02079)]; (* Superscript 4-9. *) + single 0x0002E; (* Dot. *) + ]; + mk_lookup_table_from_unicode_tables_for Letter + [ + single 0x005F; (* Underscore. *) + single 0x00A0; (* Non breaking space. *) + ]; + mk_lookup_table_from_unicode_tables_for IdentPart + [ + single 0x0027; (* Special space. *) + ]; + (* Lookup *) + lookup + +exception End_of_input + +let utf8_of_unicode n = + if n < 128 then + String.make 1 (Char.chr n) + else if n < 2048 then + let s = String.make 2 (Char.chr (128 + n mod 64)) in + begin + s.[0] <- Char.chr (192 + n / 64); + s + end + else if n < 65536 then + let s = String.make 3 (Char.chr (128 + n mod 64)) in + begin + s.[1] <- Char.chr (128 + (n / 64) mod 64); + s.[0] <- Char.chr (224 + n / 4096); + s + end + else + let s = String.make 4 (Char.chr (128 + n mod 64)) in + begin + s.[2] <- Char.chr (128 + (n / 64) mod 64); + s.[1] <- Char.chr (128 + (n / 4096) mod 64); + s.[0] <- Char.chr (240 + n / 262144); + s + end + +let next_utf8 s i = + let err () = invalid_arg "utf8" in + let l = String.length s - i in + if l = 0 then raise End_of_input + else let a = Char.code s.[i] in if a <= 0x7F then + 1, a + else if a land 0x40 = 0 || l = 1 then err () + else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err () + else if a land 0x20 = 0 then + 2, (a land 0x1F) lsl 6 + (b land 0x3F) + else if l = 2 then err () + else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err () + else if a land 0x10 = 0 then + 3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F) + else if l = 3 then err () + else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err () + else if a land 0x08 = 0 then + 4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 + + (c land 0x3F) lsl 6 + (d land 0x3F) + else err () + +(* Check the well-formedness of an identifier *) + +let initial_refutation j n s = + match classify n with + | Letter -> None + | _ -> + let c = String.sub s 0 j in + Some (false, + "Invalid character '"^c^"' at beginning of identifier \""^s^"\".") + +let trailing_refutation i j n s = + match classify n with + | Letter | IdentPart -> None + | _ -> + let c = String.sub s i j in + Some (false, + "Invalid character '"^c^"' in identifier \""^s^"\".") + +let ident_refutation s = + if s = ".." then None else try + let j, n = next_utf8 s 0 in + match initial_refutation j n s with + |None -> + begin try + let rec aux i = + let j, n = next_utf8 s i in + match trailing_refutation i j n s with + |None -> aux (i + j) + |x -> x + in aux j + with End_of_input -> None + end + |x -> x + with + | End_of_input -> Some (true,"The empty string is not an identifier.") + | Unsupported -> Some (true,s^": unsupported character in utf8 sequence.") + | Invalid_argument _ -> Some (true,s^": invalid utf8 sequence.") + +let lowercase_unicode = + let tree = Segmenttree.make Unicodetable.to_lower in + fun unicode -> + try + match Segmenttree.lookup unicode tree with + | `Abs c -> c + | `Delta d -> unicode + d + with Not_found -> unicode + +let lowercase_first_char s = + assert (s <> ""); + let j, n = next_utf8 s 0 in + utf8_of_unicode (lowercase_unicode n) + +(** For extraction, we need to encode unicode character into ascii ones *) + +let is_basic_ascii s = + let ok = ref true in + String.iter (fun c -> if Char.code c >= 128 then ok := false) s; + !ok + +let ascii_of_ident s = + if is_basic_ascii s then s else + let i = ref 0 and out = ref "" in + begin try while true do + let j, n = next_utf8 s !i in + out := + if n >= 128 + then Printf.sprintf "%s__U%04x_" !out n + else Printf.sprintf "%s%c" !out s.[!i]; + i := !i + j + done with End_of_input -> () end; + !out diff --git a/lib/unicode.mli b/lib/unicode.mli new file mode 100644 index 00000000..098f6c91 --- /dev/null +++ b/lib/unicode.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Unicode utilities *) + +type status = Letter | IdentPart | Symbol + +exception Unsupported + +(** Classify a unicode char into 3 classes, or raise [Unsupported] *) +val classify : int -> status + +(** Check whether a given string be used as a legal identifier. + - [None] means yes + - [Some (b,s)] means no, with explanation [s] and severity [b] *) +val ident_refutation : string -> (bool * string) option + +(** First char of a string, converted to lowercase *) +val lowercase_first_char : string -> string + +(** For extraction, turn a unicode string into an ascii-only one *) +val is_basic_ascii : string -> bool +val ascii_of_ident : string -> string diff --git a/lib/unionfind.ml b/lib/unionfind.ml index 300e8b0e..c44aa736 100644 --- a/lib/unionfind.ml +++ b/lib/unionfind.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -53,7 +53,28 @@ module type PartitionSig = sig end -module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct +module type SetS = +sig + type t + type elt + val singleton : elt -> t + val union : t -> t -> t + val choose : t -> elt + val iter : (elt -> unit) -> t -> unit +end + +module type MapS = +sig + type key + type +'a t + val empty : 'a t + val find : key -> 'a t -> 'a + val add : key -> 'a -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end + +module Make (S:SetS)(M:MapS with type key = S.elt) = struct type elt = S.elt type set = S.t @@ -101,7 +122,7 @@ module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct let union_set s p = try - let x = S.min_elt s in + let x = S.choose s in S.iter (fun y -> union x y p) s with Not_found -> () diff --git a/lib/unionfind.mli b/lib/unionfind.mli index 0db9ff08..310d5e2a 100644 --- a/lib/unionfind.mli +++ b/lib/unionfind.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -51,7 +51,30 @@ module type PartitionSig = sig end +module type SetS = +sig + type t + type elt + val singleton : elt -> t + val union : t -> t -> t + val choose : t -> elt + val iter : (elt -> unit) -> t -> unit +end +(** Minimal interface for sets, subtype of stdlib's Set. *) + +module type MapS = +sig + type key + type +'a t + val empty : 'a t + val find : key -> 'a t -> 'a + val add : key -> 'a -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end +(** Minimal interface for maps, subtype of stdlib's Map. *) + module Make : - functor (S:Set.S) -> - functor (M:Map.S with type key = S.elt) -> + functor (S:SetS) -> + functor (M:MapS with type key = S.elt) -> PartitionSig with type elt = S.elt and type set = S.t diff --git a/lib/util.ml b/lib/util.ml index 4f14b83a..a8c25f74 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -6,47 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -open Pp -open Compat - -(* Errors *) - -exception Anomaly of string * std_ppcmds (* System errors *) -let anomaly string = raise (Anomaly(string, str string)) -let anomalylabstrm string pps = raise (Anomaly(string,pps)) - -exception UserError of string * std_ppcmds (* User errors *) -let error string = raise (UserError("_", str string)) -let errorlabstrm l pps = raise (UserError(l,pps)) - -exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *) -let alreadydeclared pps = raise (AlreadyDeclared(pps)) - -let todo s = prerr_string ("TODO: "^s^"\n") - -exception Timeout - -type loc = Loc.t -let dummy_loc = Loc.ghost -let join_loc = Loc.merge -let make_loc = make_loc -let unloc = unloc - -(* raising located exceptions *) -type 'a located = loc * 'a -let anomaly_loc (loc,s,strm) = Loc.raise loc (Anomaly (s,strm)) -let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm)) -let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s) - -let located_fold_left f x (_,a) = f x a -let located_iter2 f (_,a) (_,b) = f a b -let down_located f (_,a) = f a - -(* Like Exc_located, but specifies the outermost file read, the filename - associated to the location of the error, and the error itself. *) - -exception Error_in_file of string * (bool * string * loc) * exn - (* Mapping under pairs *) let on_fst f (a,b) = (f a,b) @@ -65,1195 +24,64 @@ let pi1 (a,_,_) = a let pi2 (_,a,_) = a let pi3 (_,_,a) = a -(* Projection operator *) - -let down_fst f x = f (fst x) -let down_snd f x = f (snd x) - (* Characters *) -let is_letter c = (c >= 'a' && c <= 'z') or (c >= 'A' && c <= 'Z') +let is_letter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') let is_digit c = (c >= '0' && c <= '9') let is_ident_tail c = - is_letter c or is_digit c or c = '\'' or c = '_' + is_letter c || is_digit c || c = '\'' || c = '_' let is_blank = function | ' ' | '\r' | '\t' | '\n' -> true | _ -> false -(* Strings *) - -let explode s = - let rec explode_rec n = - if n >= String.length s then - [] - else - String.make 1 (String.get s n) :: explode_rec (succ n) - in - explode_rec 0 - -let implode sl = String.concat "" sl - -let strip s = - let n = String.length s in - let rec lstrip_rec i = - if i < n && is_blank s.[i] then - lstrip_rec (i+1) - else i - in - let rec rstrip_rec i = - if i >= 0 && is_blank s.[i] then - rstrip_rec (i-1) - else i - in - let a = lstrip_rec 0 and b = rstrip_rec (n-1) in - String.sub s a (b-a+1) - -let drop_simple_quotes s = - let n = String.length s in - if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s - -(* substring searching... *) - -(* gdzie = where, co = what *) -(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *) -let rec is_sub gdzie gl gi co cl ci = - (ci>=cl) || - ((String.unsafe_get gdzie gi = String.unsafe_get co ci) && - (is_sub gdzie gl (gi+1) co cl (ci+1))) - -let rec raw_str_index i gdzie l c co cl = - (* First adapt to ocaml 3.11 new semantics of index_from *) - if (i+cl > l) then raise Not_found; - (* Then proceed as in ocaml < 3.11 *) - let i' = String.index_from gdzie i c in - if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else - raw_str_index (i'+1) gdzie l c co cl - -let string_index_from gdzie i co = - if co="" then i else - raw_str_index i gdzie (String.length gdzie) - (String.unsafe_get co 0) co (String.length co) - -let string_string_contains ~where ~what = - try - let _ = string_index_from where 0 what in true - with - Not_found -> false - -let plural n s = if n<>1 then s^"s" else s - -let ordinal n = - let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in - string_of_int n ^ s - -(* string parsing *) - -let split_string_at c s = - let len = String.length s in - let rec split n = - try - let pos = String.index_from s n c in - let dir = String.sub s n (pos-n) in - dir :: split (succ pos) - with - | Not_found -> [String.sub s n (len-n)] - in - if len = 0 then [] else split 0 - -let parse_loadpath s = - let l = split_string_at '/' s in - if List.mem "" l then - invalid_arg "parse_loadpath: find an empty dir in loadpath"; - l - -module Stringset = Set.Make(struct type t = string let compare = compare end) - -module Stringmap = Map.Make(struct type t = string let compare = compare end) - -type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol - -exception UnsupportedUtf8 - -(* The following table stores classes of Unicode characters that - are used by the lexer. There are 3 different classes so 2 bits are - allocated for each character. We only use 16 bits over the 31 bits - to simplify the masking process. (This choice seems to be a good - trade-off between speed and space after some benchmarks.) *) - -(* A 256ko table, initially filled with zeros. *) -let table = Array.create (1 lsl 17) 0 - -(* Associate a 2-bit pattern to each status at position [i]. - Only the 3 lowest bits of [i] are taken into account to - define the position of the pattern in the word. - Notice that pattern "00" means "undefined". *) -let mask i = function - | UnicodeLetter -> 1 lsl ((i land 7) lsl 1) (* 01 *) - | UnicodeIdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *) - | UnicodeSymbol -> 3 lsl ((i land 7) lsl 1) (* 11 *) - -(* Helper to reset 2 bits in a word. *) -let reset_mask i = - lnot (3 lsl ((i land 7) lsl 1)) - -(* Initialize the lookup table from a list of segments, assigning - a status to every character of each segment. The order of these - assignments is relevant: it is possible to assign status [s] to - a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is - between [c1] and [c2]. *) -let mk_lookup_table_from_unicode_tables_for status tables = - List.iter - (List.iter - (fun (c1, c2) -> - for i = c1 to c2 do - table.(i lsr 3) <- - (table.(i lsr 3) land (reset_mask i)) lor (mask i status) - done)) - tables - -(* Look up into the table and interpret the found pattern. *) -let lookup x = - let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in - if v = 1 then UnicodeLetter - else if v = 2 then UnicodeIdentPart - else if v = 3 then UnicodeSymbol - else raise UnsupportedUtf8 - -(* [classify_unicode] discriminates between 3 different kinds of - symbols based on the standard unicode classification (extracted from - Camomile). *) -let classify_unicode = - let single c = [ (c, c) ] in - (* General tables. *) - mk_lookup_table_from_unicode_tables_for UnicodeSymbol - [ - Unicodetable.sm; (* Symbol, maths. *) - Unicodetable.sc; (* Symbol, currency. *) - Unicodetable.so; (* Symbol, modifier. *) - Unicodetable.pd; (* Punctation, dash. *) - Unicodetable.pc; (* Punctation, connector. *) - Unicodetable.pe; (* Punctation, open. *) - Unicodetable.ps; (* Punctation, close. *) - Unicodetable.pi; (* Punctation, initial quote. *) - Unicodetable.pf; (* Punctation, final quote. *) - Unicodetable.po; (* Punctation, other. *) - ]; - mk_lookup_table_from_unicode_tables_for UnicodeLetter - [ - Unicodetable.lu; (* Letter, uppercase. *) - Unicodetable.ll; (* Letter, lowercase. *) - Unicodetable.lt; (* Letter, titlecase. *) - Unicodetable.lo; (* Letter, others. *) - ]; - mk_lookup_table_from_unicode_tables_for UnicodeIdentPart - [ - Unicodetable.nd; (* Number, decimal digits. *) - Unicodetable.nl; (* Number, letter. *) - Unicodetable.no; (* Number, other. *) - ]; - (* Exceptions (from a previous version of this function). *) - mk_lookup_table_from_unicode_tables_for UnicodeSymbol - [ - single 0x000B2; (* Squared. *) - single 0x0002E; (* Dot. *) - ]; - mk_lookup_table_from_unicode_tables_for UnicodeLetter - [ - single 0x005F; (* Underscore. *) - single 0x00A0; (* Non breaking space. *) - ]; - mk_lookup_table_from_unicode_tables_for UnicodeIdentPart - [ - single 0x0027; (* Special space. *) - ]; - (* Lookup *) - lookup - -exception End_of_input - -let utf8_of_unicode n = - if n < 128 then - String.make 1 (Char.chr n) - else if n < 2048 then - let s = String.make 2 (Char.chr (128 + n mod 64)) in - begin - s.[0] <- Char.chr (192 + n / 64); - s - end - else if n < 65536 then - let s = String.make 3 (Char.chr (128 + n mod 64)) in - begin - s.[1] <- Char.chr (128 + (n / 64) mod 64); - s.[0] <- Char.chr (224 + n / 4096); - s - end - else - let s = String.make 4 (Char.chr (128 + n mod 64)) in - begin - s.[2] <- Char.chr (128 + (n / 64) mod 64); - s.[1] <- Char.chr (128 + (n / 4096) mod 64); - s.[0] <- Char.chr (240 + n / 262144); - s - end - -let next_utf8 s i = - let err () = invalid_arg "utf8" in - let l = String.length s - i in - if l = 0 then raise End_of_input - else let a = Char.code s.[i] in if a <= 0x7F then - 1, a - else if a land 0x40 = 0 or l = 1 then err () - else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err () - else if a land 0x20 = 0 then - 2, (a land 0x1F) lsl 6 + (b land 0x3F) - else if l = 2 then err () - else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err () - else if a land 0x10 = 0 then - 3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F) - else if l = 3 then err () - else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err () - else if a land 0x08 = 0 then - 4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 + - (c land 0x3F) lsl 6 + (d land 0x3F) - else err () - -(* Check the well-formedness of an identifier *) +module Empty = +struct + type t + let abort (x : t) = assert false +end -let check_initial handle j n s = - match classify_unicode n with - | UnicodeLetter -> () - | _ -> - let c = String.sub s 0 j in - handle ("Invalid character '"^c^"' at beginning of identifier \""^s^"\".") +(* Strings *) -let check_trailing handle i j n s = - match classify_unicode n with - | UnicodeLetter | UnicodeIdentPart -> () - | _ -> - let c = String.sub s i j in - handle ("Invalid character '"^c^"' in identifier \""^s^"\".") +module String : CString.ExtS = CString -let check_ident_gen handle s = +let subst_command_placeholder s t = + let buff = Buffer.create (String.length s + String.length t) in let i = ref 0 in - if s <> ".." then try - let j, n = next_utf8 s 0 in - check_initial handle j n s; - i := !i + j; - try - while true do - let j, n = next_utf8 s !i in - check_trailing handle !i j n s; - i := !i + j - done - with End_of_input -> () - with - | End_of_input -> error "The empty string is not an identifier." - | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.") - | Invalid_argument _ -> error (s^": invalid utf8 sequence.") - -let check_ident_soft = check_ident_gen warning -let check_ident = check_ident_gen error - -let lowercase_unicode = - let tree = Segmenttree.make Unicodetable.to_lower in - fun unicode -> - try - match Segmenttree.lookup unicode tree with - | `Abs c -> c - | `Delta d -> unicode + d - with Not_found -> unicode - -let lowercase_first_char_utf8 s = - assert (s <> ""); - let j, n = next_utf8 s 0 in - utf8_of_unicode (lowercase_unicode n) - -(** For extraction, we need to encode unicode character into ascii ones *) - -let ascii_of_ident s = - let check_ascii s = - let ok = ref true in - String.iter (fun c -> if Char.code c >= 128 then ok := false) s; - !ok - in - if check_ascii s then s else - let i = ref 0 and out = ref "" in - begin try while true do - let j, n = next_utf8 s !i in - out := - if n >= 128 - then Printf.sprintf "%s__U%04x_" !out n - else Printf.sprintf "%s%c" !out s.[!i]; - i := !i + j - done with End_of_input -> () end; - !out + while (!i < String.length s) do + if s.[!i] = '%' && !i+1 < String.length s && s.[!i+1] = 's' + then (Buffer.add_string buff t;incr i) + else Buffer.add_char buff s.[!i]; + incr i + done; + Buffer.contents buff (* Lists *) -let rec list_compare cmp l1 l2 = - match l1,l2 with - [], [] -> 0 - | _::_, [] -> 1 - | [], _::_ -> -1 - | x1::l1, x2::l2 -> - (match cmp x1 x2 with - | 0 -> list_compare cmp l1 l2 - | c -> c) - -let rec list_equal cmp l1 l2 = - match l1, l2 with - | [], [] -> true - | x1 :: l1, x2 :: l2 -> - cmp x1 x2 && list_equal cmp l1 l2 - | _ -> false - -let list_intersect l1 l2 = - List.filter (fun x -> List.mem x l2) l1 - -let list_union l1 l2 = - let rec urec = function - | [] -> l2 - | a::l -> if List.mem a l2 then urec l else a::urec l - in - urec l1 - -let list_unionq l1 l2 = - let rec urec = function - | [] -> l2 - | a::l -> if List.memq a l2 then urec l else a::urec l - in - urec l1 - -let list_subtract l1 l2 = - if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1 - -let list_subtractq l1 l2 = - if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1 - -let list_tabulate f len = - let rec tabrec n = - if n = len then [] else (f n)::(tabrec (n+1)) - in - tabrec 0 - -let list_addn n v = - let rec aux n l = - if n = 0 then l - else aux (pred n) (v::l) - in - if n < 0 then invalid_arg "list_addn" - else aux n - -let list_make n v = list_addn n v [] - -let list_assign l n e = - let rec assrec stk = function - | ((h::t), 0) -> List.rev_append stk (e::t) - | ((h::t), n) -> assrec (h::stk) (t, n-1) - | ([], _) -> failwith "list_assign" - in - assrec [] (l,n) - -let rec list_smartmap f l = match l with - [] -> l - | h::tl -> - let h' = f h and tl' = list_smartmap f tl in - if h'==h && tl'==tl then l - else h'::tl' - -let list_map_left f = (* ensures the order in case of side-effects *) - let rec map_rec = function - | [] -> [] - | x::l -> let v = f x in v :: map_rec l - in - map_rec - -let list_map_i f = - let rec map_i_rec i = function - | [] -> [] - | x::l -> let v = f i x in v :: map_i_rec (i+1) l - in - map_i_rec - -let list_map2_i f i l1 l2 = - let rec map_i i = function - | ([], []) -> [] - | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2) - | (_, _) -> invalid_arg "map2_i" - in - map_i i (l1,l2) - -let list_map3 f l1 l2 l3 = - let rec map = function - | ([], [], []) -> [] - | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3) - | (_, _, _) -> invalid_arg "map3" - in - map (l1,l2,l3) - -let list_map4 f l1 l2 l3 l4 = - let rec map = function - | ([], [], [], []) -> [] - | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4) - | (_, _, _, _) -> invalid_arg "map4" - in - map (l1,l2,l3,l4) - -let list_map_to_array f l = - Array.of_list (List.map f l) - -let rec list_smartfilter f l = match l with - [] -> l - | h::tl -> - let tl' = list_smartfilter f tl in - if f h then - if tl' == tl then l - else h :: tl' - else tl' - -let list_index_f f x = - let rec index_x n = function - | y::l -> if f x y then n else index_x (succ n) l - | [] -> raise Not_found - in - index_x 1 - -let list_index0_f f x l = list_index_f f x l - 1 - -let list_index x = - let rec index_x n = function - | y::l -> if x = y then n else index_x (succ n) l - | [] -> raise Not_found - in - index_x 1 - -let list_index0 x l = list_index x l - 1 - -let list_unique_index x = - let rec index_x n = function - | y::l -> - if x = y then - if List.mem x l then raise Not_found - else n - else index_x (succ n) l - | [] -> raise Not_found - in index_x 1 - -let list_fold_right_i f i l = - let rec it_list_f i l a = match l with - | [] -> a - | b::l -> f (i-1) b (it_list_f (i-1) l a) - in - it_list_f (List.length l + i) l - -let list_fold_left_i f = - let rec it_list_f i a = function - | [] -> a - | b::l -> it_list_f (i+1) (f i a b) l - in - it_list_f - -let rec list_fold_left3 f accu l1 l2 l3 = - match (l1, l2, l3) with - ([], [], []) -> accu - | (a1::l1, a2::l2, a3::l3) -> list_fold_left3 f (f accu a1 a2 a3) l1 l2 l3 - | (_, _, _) -> invalid_arg "list_fold_left3" - -(* [list_fold_right_and_left f [a1;...;an] hd = - f (f (... (f (f hd - an - [an-1;...;a1]) - an-1 - [an-2;...;a1]) - ...) - a2 - [a1]) - a1 - []] *) - -let rec list_fold_right_and_left f l hd = - let rec aux tl = function - | [] -> hd - | a::l -> let hd = aux (a::tl) l in f hd a tl - in aux [] l - -let list_iter3 f l1 l2 l3 = - let rec iter = function - | ([], [], []) -> () - | ((h1::t1), (h2::t2), (h3::t3)) -> f h1 h2 h3; iter (t1,t2,t3) - | (_, _, _) -> invalid_arg "map3" - in - iter (l1,l2,l3) - -let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l - -let list_for_all_i p = - let rec for_all_p i = function - | [] -> true - | a::l -> p i a && for_all_p (i+1) l - in - for_all_p - -let list_except x l = List.filter (fun y -> not (x = y)) l - -let list_remove = list_except (* Alias *) - -let rec list_remove_first a = function - | b::l when a = b -> l - | b::l -> b::list_remove_first a l - | [] -> raise Not_found - -let rec list_remove_assoc_in_triple x = function - | [] -> [] - | (y,_,_ as z)::l -> if x = y then l else z::list_remove_assoc_in_triple x l - -let rec list_assoc_snd_in_triple x = function - [] -> raise Not_found - | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_snd_in_triple x l - -let list_add_set x l = if List.mem x l then l else x::l - -let list_eq_set l1 l2 = - let rec aux l1 = function - | [] -> l1 = [] - | a::l2 -> aux (list_remove_first a l1) l2 in - try aux l1 l2 with Not_found -> false - -let list_for_all2eq f l1 l2 = - try List.for_all2 f l1 l2 with Invalid_argument _ -> false - -let list_filter_i p = - let rec filter_i_rec i = function - | [] -> [] - | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l' - in - filter_i_rec 0 - -let rec list_sep_last = function - | [] -> failwith "sep_last" - | hd::[] -> (hd,[]) - | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl) - -let list_try_find_i f = - let rec try_find_f n = function - | [] -> failwith "try_find_i" - | h::t -> try f n h with Failure _ -> try_find_f (n+1) t - in - try_find_f - -let list_try_find f = - let rec try_find_f = function - | [] -> failwith "try_find" - | h::t -> try f h with Failure _ -> try_find_f t - in - try_find_f - -let list_uniquize l = - let visited = Hashtbl.create 23 in - let rec aux acc = function - | h::t -> if Hashtbl.mem visited h then aux acc t else - begin - Hashtbl.add visited h h; - aux (h::acc) t - end - | [] -> List.rev acc - in aux [] l - -let rec list_distinct l = - let visited = Hashtbl.create 23 in - let rec loop = function - | h::t -> - if Hashtbl.mem visited h then false - else - begin - Hashtbl.add visited h h; - loop t - end - | [] -> true - in loop l - -let rec list_merge_uniq cmp l1 l2 = - match l1, l2 with - | [], l2 -> l2 - | l1, [] -> l1 - | h1 :: t1, h2 :: t2 -> - let c = cmp h1 h2 in - if c = 0 - then h1 :: list_merge_uniq cmp t1 t2 - else if c <= 0 - then h1 :: list_merge_uniq cmp t1 l2 - else h2 :: list_merge_uniq cmp l1 t2 - -let rec list_duplicates = function - | [] -> [] - | x::l -> - let l' = list_duplicates l in - if List.mem x l then list_add_set x l' else l' - -let rec list_filter2 f = function - | [], [] as p -> p - | d::dp, l::lp -> - let (dp',lp' as p) = list_filter2 f (dp,lp) in - if f d l then d::dp', l::lp' else p - | _ -> invalid_arg "list_filter2" - -let rec list_map_filter f = function - | [] -> [] - | x::l -> - let l' = list_map_filter f l in - match f x with None -> l' | Some y -> y::l' - -let list_map_filter_i f = - let rec aux i = function - | [] -> [] - | x::l -> - let l' = aux (succ i) l in - match f i x with None -> l' | Some y -> y::l' - in aux 0 - -let list_filter_along f filter l = - snd (list_filter2 (fun b c -> f b) (filter,l)) - -let list_filter_with filter l = - list_filter_along (fun x -> x) filter l - -let list_subset l1 l2 = - let t2 = Hashtbl.create 151 in - List.iter (fun x -> Hashtbl.add t2 x ()) l2; - let rec look = function - | [] -> true - | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false - in - look l1 - -(* [list_chop i l] splits [l] into two lists [(l1,l2)] such that - [l1++l2=l] and [l1] has length [i]. - It raises [Failure] when [i] is negative or greater than the length of [l] *) - -let list_chop n l = - let rec chop_aux i acc = function - | tl when i=0 -> (List.rev acc, tl) - | h::t -> chop_aux (pred i) (h::acc) t - | [] -> failwith "list_chop" - in - chop_aux n [] l - -(* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that - [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1]. - If there is no such [a], then it returns [(l,[])] instead *) -let list_split_when p = - let rec split_when_loop x y = - match y with - | [] -> (List.rev x,[]) - | (a::l) -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l - in - split_when_loop [] - -(* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of - [l1] satisfy [p] and elements of [l2] do not; order is preserved *) -let list_split_by p = - let rec split_by_loop = function - | [] -> ([],[]) - | a::l -> - let (l1,l2) = split_by_loop l in if p a then (a::l1,l2) else (l1,a::l2) - in - split_by_loop - -let rec list_split3 = function - | [] -> ([], [], []) - | (x,y,z)::l -> - let (rx, ry, rz) = list_split3 l in (x::rx, y::ry, z::rz) - -let rec list_insert_in_class f a = function - | [] -> [[a]] - | (b::_ as l)::classes when f a b -> (a::l)::classes - | l::classes -> l :: list_insert_in_class f a classes - -let list_partition_by f l = - List.fold_right (list_insert_in_class f) l [] - -let list_firstn n l = - let rec aux acc = function - | (0, l) -> List.rev acc - | (n, (h::t)) -> aux (h::acc) (pred n, t) - | _ -> failwith "firstn" - in - aux [] (n,l) - -let rec list_last = function - | [] -> failwith "list_last" - | [x] -> x - | _ :: l -> list_last l - -let list_lastn n l = - let len = List.length l in - let rec aux m l = - if m = n then l else aux (m - 1) (List.tl l) - in - if len < n then failwith "lastn" else aux len l - -let rec list_skipn n l = match n,l with - | 0, _ -> l - | _, [] -> failwith "list_skipn" - | n, _::l -> list_skipn (pred n) l - -let rec list_skipn_at_least n l = - try list_skipn n l with Failure _ -> [] - -let list_prefix_of prefl l = - let rec prefrec = function - | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2) - | ([], _) -> true - | (_, _) -> false - in - prefrec (prefl,l) - -let list_drop_prefix p l = -(* if l=p++t then return t else l *) - let rec list_drop_prefix_rec = function - | ([], tl) -> Some tl - | (_, []) -> None - | (h1::tp, h2::tl) -> - if h1 = h2 then list_drop_prefix_rec (tp,tl) else None - in - match list_drop_prefix_rec (p,l) with - | Some r -> r - | None -> l - -let list_map_append f l = List.flatten (List.map f l) -let list_join_map = list_map_append (* Alias *) - -let list_map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2) - -let list_share_tails l1 l2 = - let rec shr_rev acc = function - | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2) - | (l1,l2) -> (List.rev l1, List.rev l2, acc) - in - shr_rev [] (List.rev l1, List.rev l2) - -let rec list_fold_map f e = function - | [] -> (e,[]) - | h::t -> - let e',h' = f e h in - let e'',t' = list_fold_map f e' t in - e'',h'::t' - -(* (* tail-recursive version of the above function *) -let list_fold_map f e l = - let g (e,b') h = - let (e',h') = f e h in - (e',h'::b') - in - let (e',lrev) = List.fold_left g (e,[]) l in - (e',List.rev lrev) -*) - -(* The same, based on fold_right, with the effect accumulated on the right *) -let list_fold_map' f l e = - List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e) - -let list_map_assoc f = List.map (fun (x,a) -> (x,f a)) - -let rec list_assoc_f f a = function - | (x, e) :: xs -> if f a x then e else list_assoc_f f a xs - | [] -> raise Not_found - -(* Specification: - - =p= is set equality (double inclusion) - - f such that \forall l acc, (f l acc) =p= append (f l []) acc - - let g = fun x -> f x [] in - - union_map f l acc =p= append (flatten (map g l)) acc - *) -let list_union_map f l acc = - List.fold_left - (fun x y -> f y x) - acc - l - -(* A generic cartesian product: for any operator (**), - [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], - and so on if there are more elements in the lists. *) - -let rec list_cartesian op l1 l2 = - list_map_append (fun x -> List.map (op x) l2) l1 - -(* [list_cartesians] is an n-ary cartesian product: it iterates - [list_cartesian] over a list of lists. *) - -let list_cartesians op init ll = - List.fold_right (list_cartesian op) ll [init] - -(* list_combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *) - -let list_combinations l = list_cartesians (fun x l -> x::l) [] l - -let rec list_combine3 x y z = - match x, y, z with - | [], [], [] -> [] - | (x :: xs), (y :: ys), (z :: zs) -> - (x, y, z) :: list_combine3 xs ys zs - | _, _, _ -> raise (Invalid_argument "list_combine3") - -(* Keep only those products that do not return None *) - -let rec list_cartesian_filter op l1 l2 = - list_map_append (fun x -> list_map_filter (op x) l2) l1 +module List : CList.ExtS = CList -(* Keep only those products that do not return None *) - -let rec list_cartesians_filter op init ll = - List.fold_right (list_cartesian_filter op) ll [init] - -(* Drop the last element of a list *) - -let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: list_drop_last tl - -(* Factorize lists of pairs according to the left argument *) -let rec list_factorize_left = function - | (a,b)::l -> - let al,l' = list_split_by (fun (a',b) -> a=a') l in - (a,(b::List.map snd al)) :: list_factorize_left l' - | [] -> - [] +let (@) = CList.append (* Arrays *) -let array_compare item_cmp v1 v2 = - let c = compare (Array.length v1) (Array.length v2) in - if c<>0 then c else - let rec cmp = function - -1 -> 0 - | i -> - let c' = item_cmp v1.(i) v2.(i) in - if c'<>0 then c' - else cmp (i-1) in - cmp (Array.length v1 - 1) - -let array_equal cmp t1 t2 = - Array.length t1 = Array.length t2 && - let rec aux i = - (i = Array.length t1) || (cmp t1.(i) t2.(i) && aux (i + 1)) - in aux 0 - -let array_exists f v = - let rec exrec = function - | -1 -> false - | n -> (f v.(n)) || (exrec (n-1)) - in - exrec ((Array.length v)-1) - -let array_for_all f v = - let rec allrec = function - | -1 -> true - | n -> (f v.(n)) && (allrec (n-1)) - in - allrec ((Array.length v)-1) - -let array_for_all2 f v1 v2 = - let rec allrec = function - | -1 -> true - | n -> (f v1.(n) v2.(n)) && (allrec (n-1)) - in - let lv1 = Array.length v1 in - lv1 = Array.length v2 && allrec (pred lv1) - -let array_for_all3 f v1 v2 v3 = - let rec allrec = function - | -1 -> true - | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1)) - in - let lv1 = Array.length v1 in - lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1) - -let array_for_all4 f v1 v2 v3 v4 = - let rec allrec = function - | -1 -> true - | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1)) - in - let lv1 = Array.length v1 in - lv1 = Array.length v2 && - lv1 = Array.length v3 && - lv1 = Array.length v4 && - allrec (pred lv1) - -let array_for_all_i f i v = - let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in - allrec i 0 - -exception Found of int - -let array_find_i (pred: int -> 'a -> bool) (arr: 'a array) : int option = - try - for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; - None - with Found i -> Some i - -let array_hd v = - match Array.length v with - | 0 -> failwith "array_hd" - | _ -> v.(0) +module Array : CArray.ExtS = CArray -let array_tl v = - match Array.length v with - | 0 -> failwith "array_tl" - | n -> Array.sub v 1 (pred n) +(* Sets *) -let array_last v = - match Array.length v with - | 0 -> failwith "array_last" - | n -> v.(pred n) +module Set = CSet -let array_cons e v = Array.append [|e|] v +(* Maps *) -let array_rev t = - let n=Array.length t in - if n <=0 then () - else - let tmp=ref t.(0) in - for i=0 to pred (n/2) do - tmp:=t.((pred n)-i); - t.((pred n)-i)<- t.(i); - t.(i)<- !tmp - done +module Map = CMap -let array_fold_right_i f v a = - let rec fold a n = - if n=0 then a - else - let k = n-1 in - fold (f k v.(k) a) k in - fold a (Array.length v) +(* Stacks *) -let array_fold_left_i f v a = - let n = Array.length a in - let rec fold i v = if i = n then v else fold (succ i) (f i v a.(i)) in - fold 0 v - -let array_fold_right2 f v1 v2 a = - let lv1 = Array.length v1 in - let rec fold a n = - if n=0 then a - else - let k = n-1 in - fold (f v1.(k) v2.(k) a) k in - if Array.length v2 <> lv1 then invalid_arg "array_fold_right2"; - fold a lv1 - -let array_fold_left2 f a v1 v2 = - let lv1 = Array.length v1 in - let rec fold a n = - if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n) - in - if Array.length v2 <> lv1 then invalid_arg "array_fold_left2"; - fold a 0 - -let array_fold_left2_i f a v1 v2 = - let lv1 = Array.length v1 in - let rec fold a n = - if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n) - in - if Array.length v2 <> lv1 then invalid_arg "array_fold_left2"; - fold a 0 - -let array_fold_left3 f a v1 v2 v3 = - let lv1 = Array.length v1 in - let rec fold a n = - if n >= lv1 then a else fold (f a v1.(n) v2.(n) v3.(n)) (succ n) - in - if Array.length v2 <> lv1 || Array.length v3 <> lv1 then - invalid_arg "array_fold_left2"; - fold a 0 - -let array_fold_left_from n f a v = - let rec fold a n = - if n >= Array.length v then a else fold (f a v.(n)) (succ n) - in - fold a n - -let array_fold_right_from n f v a = - let rec fold n = - if n >= Array.length v then a else f v.(n) (fold (succ n)) - in - fold n - -let array_app_tl v l = - if Array.length v = 0 then invalid_arg "array_app_tl"; - array_fold_right_from 1 (fun e l -> e::l) v l - -let array_list_of_tl v = - if Array.length v = 0 then invalid_arg "array_list_of_tl"; - array_fold_right_from 1 (fun e l -> e::l) v [] - -let array_map_to_list f v = - List.map f (Array.to_list v) - -let array_chop n v = - let vlen = Array.length v in - if n > vlen then failwith "array_chop"; - (Array.sub v 0 n, Array.sub v n (vlen-n)) - -exception Local of int - -(* If none of the elements is changed by f we return ar itself. - The for loop looks for the first such an element. - If found it is temporarily stored in a ref and the new array is produced, - but f is not re-applied to elements that are already checked *) -let array_smartmap f ar = - let ar_size = Array.length ar in - let aux = ref None in - try - for i = 0 to ar_size-1 do - let a = ar.(i) in - let a' = f a in - if a != a' then (* pointer (in)equality *) begin - aux := Some a'; - raise (Local i) - end - done; - ar - with - Local i -> - let copy j = - if j<i then ar.(j) - else if j=i then - match !aux with Some a' -> a' | None -> failwith "Error" - else f (ar.(j)) - in - Array.init ar_size copy - -let array_map2 f v1 v2 = - if Array.length v1 <> Array.length v2 then invalid_arg "array_map2"; - if Array.length v1 == 0 then - [| |] - else begin - let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in - for i = 1 to pred (Array.length v1) do - res.(i) <- f v1.(i) v2.(i) - done; - res - end - -let array_map2_i f v1 v2 = - if Array.length v1 <> Array.length v2 then invalid_arg "array_map2"; - if Array.length v1 == 0 then - [| |] - else begin - let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in - for i = 1 to pred (Array.length v1) do - res.(i) <- f i v1.(i) v2.(i) - done; - res - end - -let array_map3 f v1 v2 v3 = - if Array.length v1 <> Array.length v2 || - Array.length v1 <> Array.length v3 then invalid_arg "array_map3"; - if Array.length v1 == 0 then - [| |] - else begin - let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in - for i = 1 to pred (Array.length v1) do - res.(i) <- f v1.(i) v2.(i) v3.(i) - done; - res - end - -let array_map_left f a = (* Ocaml does not guarantee Array.map is LR *) - let l = Array.length a in (* (even if so), then we rewrite it *) - if l = 0 then [||] else begin - let r = Array.create l (f a.(0)) in - for i = 1 to l - 1 do - r.(i) <- f a.(i) - done; - r - end - -let array_map_left_pair f a g b = - let l = Array.length a in - if l = 0 then [||],[||] else begin - let r = Array.create l (f a.(0)) in - let s = Array.create l (g b.(0)) in - for i = 1 to l - 1 do - r.(i) <- f a.(i); - s.(i) <- g b.(i) - done; - r, s - end - -let array_iter2 f v1 v2 = - let n = Array.length v1 in - if Array.length v2 <> n then invalid_arg "array_iter2" - else for i = 0 to n - 1 do f v1.(i) v2.(i) done - -let pure_functional = false - -let array_fold_map' f v e = -if pure_functional then - let (l,e) = - Array.fold_right - (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) - v ([],e) in - (Array.of_list l,e) -else - let e' = ref e in - let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in - (v',!e') - -let array_fold_map f e v = - let e' = ref e in - let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in - (!e',v') - -let array_fold_map2' f v1 v2 e = - let e' = ref e in - let v' = - array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 - in - (v',!e') - -let array_distinct v = - let visited = Hashtbl.create 23 in - try - Array.iter - (fun x -> - if Hashtbl.mem visited x then raise Exit - else Hashtbl.add visited x x) - v; - true - with Exit -> false - -let array_union_map f a acc = - Array.fold_left - (fun x y -> f y x) - acc - a - -let array_rev_to_list a = - let rec tolist i res = - if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in - tolist 0 [] - -let array_filter_along f filter v = - Array.of_list (list_filter_along f filter (Array.to_list v)) - -let array_filter_with filter v = - Array.of_list (list_filter_with filter (Array.to_list v)) - -(* Stream *) - -let stream_nth n st = - try List.nth (Stream.npeek (n+1) st) n - with Failure _ -> raise Stream.Failure - -let stream_njunk n st = - for i = 1 to n do Stream.junk st done +module Stack = CStack (* Matrices *) let matrix_transpose mat = List.fold_right (List.map2 (fun p c -> p::c)) mat - (if mat = [] then [] else List.map (fun _ -> []) (List.hd mat)) + (if List.is_empty mat then [] else List.map (fun _ -> []) (List.hd mat)) (* Functions *) @@ -1263,18 +91,28 @@ let compose f g x = f (g x) let const x _ = x -let iterate f = - let rec iterate_f n x = - if n <= 0 then x else iterate_f (pred n) (f x) +let iterate = + let rec iterate_f f n x = + if n <= 0 then x else iterate_f f (pred n) (f x) in iterate_f let repeat n f x = - for i = 1 to n do f x done + let rec loop i = if i <> 0 then (f x; loop (i - 1)) in loop n + +let app_opt f x = + match f with + | Some f -> f x + | None -> x -let iterate_for a b f x = - let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in - iterate a x +(* Stream *) + +let stream_nth n st = + try List.nth (Stream.npeek (n+1) st) n + with Failure _ -> raise Stream.Failure + +let stream_njunk n st = + repeat n Stream.junk st (* Delayed computations *) @@ -1284,245 +122,13 @@ let delayed_force f = f () (* Misc *) -type ('a,'b) union = Inl of 'a | Inr of 'b - -module Intset = Set.Make(struct type t = int let compare = compare end) - -module Intmap = Map.Make(struct type t = int let compare = compare end) - -let intmap_in_dom x m = - try let _ = Intmap.find x m in true with Not_found -> false - -let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m [] - -let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m [] - -let interval n m = - let rec interval_n (l,m) = - if n > m then l else interval_n (m::l,pred m) - in - interval_n ([],m) - - -let map_succeed f = - let rec map_f = function - | [] -> [] - | h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t - in - map_f - -(* Pretty-printing *) - -let pr_spc = spc -let pr_fnl = fnl -let pr_int = int -let pr_str = str -let pr_comma () = str "," ++ spc () -let pr_semicolon () = str ";" ++ spc () -let pr_bar () = str "|" ++ spc () -let pr_arg pr x = spc () ++ pr x -let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x -let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x - -let nth n = str (ordinal n) - -(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) - -let rec prlist elem l = match l with - | [] -> mt () - | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t) - -(* unlike all other functions below, [prlist] works lazily. - if a strict behavior is needed, use [prlist_strict] instead. - evaluation is done from left to right. *) - -let rec prlist_strict elem l = match l with - | [] -> mt () - | h::t -> - let e = elem h in let r = prlist_strict elem t in e++r - -(* [prlist_with_sep sep pr [a ; ... ; c]] outputs - [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) - -let rec prlist_with_sep sep elem l = match l with - | [] -> mt () - | [h] -> elem h - | h::t -> - let e = elem h and s = sep() and r = prlist_with_sep sep elem t in - e ++ s ++ r - -(* Print sequence of objects separated by space (unless an element is empty) *) - -let rec pr_sequence elem = function - | [] -> mt () - | [h] -> elem h - | h::t -> - let e = elem h and r = pr_sequence elem t in - if e = mt () then r else e ++ spc () ++ r - -(* [pr_enum pr [a ; b ; ... ; c]] outputs - [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *) - -let pr_enum pr l = - let c,l' = list_sep_last l in - prlist_with_sep pr_comma pr l' ++ - (if l'<>[] then str " and" ++ spc () else mt()) ++ pr c - -let pr_vertical_list pr = function - | [] -> str "none" ++ fnl () - | l -> fnl () ++ str " " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl () - -(* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs - [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *) - -let prvecti_with_sep sep elem v = - let rec pr i = - if i = 0 then - elem 0 v.(0) - else - let r = pr (i-1) and s = sep () and e = elem i v.(i) in - r ++ s ++ e - in - let n = Array.length v in - if n = 0 then mt () else pr (n - 1) - -(* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *) - -let prvecti elem v = prvecti_with_sep mt elem v - -(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs - [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) - -let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v - -(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *) - -let prvect elem v = prvect_with_sep mt elem v - -let pr_located pr (loc,x) = - if Flags.do_beautify() && loc<>dummy_loc then - let (b,e) = unloc loc in - comment b ++ pr x ++ comment e - else pr x - -let surround p = hov 1 (str"(" ++ p ++ str")") - -(*s Memoization *) - -let memo1_eq eq f = - let m = ref None in - fun x -> - match !m with - Some(x',y') when eq x x' -> y' - | _ -> let y = f x in m := Some(x,y); y - -let memo1_1 f = memo1_eq (==) f -let memo1_2 f = - let f' = - memo1_eq (fun (x,y) (x',y') -> x==x' && y==y') (fun (x,y) -> f x y) in - (fun x y -> f'(x,y)) - -(* Memorizes the last n distinct calls to f. Since there is no hash, - Efficient only for small n. *) -let memon_eq eq n f = - let cache = ref [] in (* the cache: a stack *) - let m = ref 0 in (* usage of the cache *) - let rec find x = function - | (x',y')::l when eq x x' -> y', l (* cell is moved to the top *) - | [] -> (* we assume n>0, so creating one memo cell is OK *) - incr m; (f x, []) - | [_] when !m>=n -> f x,[] (* cache is full: dispose of last cell *) - | p::l (* not(eq x (fst p)) *) -> let (y,l') = find x l in (y, p::l') - in - (fun x -> - let (y,l) = find x !cache in - cache := (x,y)::l; - y) - - -(*s Size of ocaml values. *) - -module Size = struct - - (*s Pointers already visited are stored in a hash-table, where - comparisons are done using physical equality. *) - - module H = Hashtbl.Make( - struct - type t = Obj.t - let equal = (==) - let hash o = Hashtbl.hash (Obj.magic o : int) - end) - - let node_table = (H.create 257 : unit H.t) - - let in_table o = try H.find node_table o; true with Not_found -> false - - let add_in_table o = H.add node_table o () - - let reset_table () = H.clear node_table - - (*s Objects are traversed recursively, as soon as their tags are less than - [no_scan_tag]. [count] records the numbers of words already visited. *) - - let size_of_double = Obj.size (Obj.repr 1.0) - - let count = ref 0 - - let rec traverse t = - if not (in_table t) then begin - add_in_table t; - if Obj.is_block t then begin - let n = Obj.size t in - let tag = Obj.tag t in - if tag < Obj.no_scan_tag then begin - count := !count + 1 + n; - for i = 0 to n - 1 do - let f = Obj.field t i in - if Obj.is_block f then traverse f - done - end else if tag = Obj.string_tag then - count := !count + 1 + n - else if tag = Obj.double_tag then - count := !count + size_of_double - else if tag = Obj.double_array_tag then - count := !count + 1 + size_of_double * n - else - incr count - end - end - - (*s Sizes of objects in words and in bytes. The size in bytes is computed - system-independently according to [Sys.word_size]. *) - - let size_w o = - reset_table (); - count := 0; - traverse (Obj.repr o); - !count - - let size_b o = (size_w o) * (Sys.word_size / 8) - - let size_kb o = (size_w o) / (8192 / Sys.word_size) - -end - -let size_w = Size.size_w -let size_b = Size.size_b -let size_kb = Size.size_kb - -(*s Total size of the allocated ocaml heap. *) - -let heap_size () = - let stat = Gc.stat () - and control = Gc.get () in - let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in - (max_words_total * (Sys.word_size / 8)) +type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b +type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a -let heap_size_kb () = (heap_size () + 1023) / 1024 +let map_union f g = function + | Inl a -> Inl (f a) + | Inr b -> Inr (g b) -(*s interruption *) +type iexn = Exninfo.iexn -let interrupt = ref false -let check_for_interrupt () = - if !interrupt then begin interrupt := false; raise Sys.Break end +let iraise = Exninfo.iraise diff --git a/lib/util.mli b/lib/util.mli index 530e838a..4fce809c 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -1,73 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp -open Compat - (** This module contains numerous utility functions on strings, lists, arrays, etc. *) -(** {6 ... } *) -(** Errors. [Anomaly] is used for system errors and [UserError] for the - user's ones. *) - -exception Anomaly of string * std_ppcmds -val anomaly : string -> 'a -val anomalylabstrm : string -> std_ppcmds -> 'a - -exception UserError of string * std_ppcmds -val error : string -> 'a -val errorlabstrm : string -> std_ppcmds -> 'a - -exception AlreadyDeclared of std_ppcmds -val alreadydeclared : std_ppcmds -> 'a - -(** [todo] is for running of an incomplete code its implementation is - "do nothing" (or print a message), but this function should not be - used in a released code *) - -val todo : string -> unit - -exception Timeout - -type loc = Loc.t - -type 'a located = loc * 'a - -val unloc : loc -> int * int -val make_loc : int * int -> loc -val dummy_loc : loc -val join_loc : loc -> loc -> loc - -val anomaly_loc : loc * string * std_ppcmds -> 'a -val user_err_loc : loc * string * std_ppcmds -> 'a -val invalid_arg_loc : loc * string -> 'a -val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a -val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit -val down_located : ('a -> 'b) -> 'a located -> 'b - -(** Like [Exc_located], but specifies the outermost file read, the - input buffer associated to the location of the error (or the module name - if boolean is true), and the error itself. *) - -exception Error_in_file of string * (bool * string * loc) * exn - (** Mapping under pairs *) val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b -(** Going down pairs *) - -val down_fst : ('a -> 'b) -> 'a * 'c -> 'b -val down_snd : ('a -> 'b) -> 'c * 'a -> 'b - (** Mapping under triple *) val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd @@ -87,216 +34,42 @@ val is_digit : char -> bool val is_ident_tail : char -> bool val is_blank : char -> bool +(** {6 Empty type} *) + +module Empty : +sig + type t + val abort : t -> 'a +end + (** {6 Strings. } *) -val explode : string -> string list -val implode : string list -> string -val strip : string -> string -val drop_simple_quotes : string -> string -val string_index_from : string -> int -> string -> int -val string_string_contains : where:string -> what:string -> bool -val plural : int -> string -> string -val ordinal : int -> string -val split_string_at : char -> string -> string list +module String : CString.ExtS -val parse_loadpath : string -> string list +(** Substitute %s in the first chain by the second chain *) +val subst_command_placeholder : string -> string -> string -module Stringset : Set.S with type elt = string -module Stringmap : Map.S with type key = string +(** {6 Lists. } *) -type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol +module List : CList.ExtS -exception UnsupportedUtf8 +val (@) : 'a list -> 'a list -> 'a list -val classify_unicode : int -> utf8_status -val check_ident : string -> unit -val check_ident_soft : string -> unit -val lowercase_first_char_utf8 : string -> string -val ascii_of_ident : string -> string +(** {6 Arrays. } *) -(** {6 Lists. } *) +module Array : CArray.ExtS -val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int -val list_equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool -val list_add_set : 'a -> 'a list -> 'a list -val list_eq_set : 'a list -> 'a list -> bool -val list_intersect : 'a list -> 'a list -> 'a list -val list_union : 'a list -> 'a list -> 'a list -val list_unionq : 'a list -> 'a list -> 'a list -val list_subtract : 'a list -> 'a list -> 'a list -val list_subtractq : 'a list -> 'a list -> 'a list - -(** [list_tabulate f n] builds [[f 0; ...; f (n-1)]] *) -val list_tabulate : (int -> 'a) -> int -> 'a list -val list_make : int -> 'a -> 'a list -val list_assign : 'a list -> int -> 'a -> 'a list -val list_distinct : 'a list -> bool -val list_duplicates : 'a list -> 'a list -val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list -val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list -val list_map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list -val list_filter_with : bool list -> 'a list -> 'a list -val list_filter_along : ('a -> bool) -> 'a list -> 'b list -> 'b list - -(** [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i - [ f ai == ai], then [list_smartmap f l==l] *) -val list_smartmap : ('a -> 'a) -> 'a list -> 'a list -val list_map_left : ('a -> 'b) -> 'a list -> 'b list -val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list -val list_map2_i : - (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list -val list_map3 : - ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list -val list_map4 : - ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list -val list_map_to_array : ('a -> 'b) -> 'a list -> 'b array -val list_filter_i : - (int -> 'a -> bool) -> 'a list -> 'a list - -(** [list_smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i - [f ai = true], then [list_smartfilter f l==l] *) -val list_smartfilter : ('a -> bool) -> 'a list -> 'a list - -(** [list_index] returns the 1st index of an element in a list (counting from 1) *) -val list_index : 'a -> 'a list -> int -val list_index_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int - -(** [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *) -val list_unique_index : 'a -> 'a list -> int - -(** [list_index0] behaves as [list_index] except that it starts counting at 0 *) -val list_index0 : 'a -> 'a list -> int -val list_index0_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int -val list_iter3 : ('a -> 'b -> 'c -> unit) -> 'a list -> 'b list -> 'c list -> unit -val list_iter_i : (int -> 'a -> unit) -> 'a list -> unit -val list_fold_right_i : (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b -val list_fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a -val list_fold_right_and_left : - ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a -val list_fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a -val list_for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool -val list_except : 'a -> 'a list -> 'a list -val list_remove : 'a -> 'a list -> 'a list -val list_remove_first : 'a -> 'a list -> 'a list -val list_remove_assoc_in_triple : 'a -> ('a * 'b * 'c) list -> ('a * 'b * 'c) list -val list_assoc_snd_in_triple : 'a -> ('a * 'b * 'c) list -> 'b -val list_for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool -val list_sep_last : 'a list -> 'a * 'a list -val list_try_find_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b -val list_try_find : ('a -> 'b) -> 'a list -> 'b -val list_uniquize : 'a list -> 'a list - -(** merges two sorted lists and preserves the uniqueness property: *) -val list_merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list -val list_subset : 'a list -> 'a list -> bool -val list_chop : int -> 'a list -> 'a list * 'a list -(* former [list_split_at] was a duplicate of [list_chop] *) -val list_split_when : ('a -> bool) -> 'a list -> 'a list * 'a list -val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list -val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list -val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list -val list_firstn : int -> 'a list -> 'a list -val list_last : 'a list -> 'a -val list_lastn : int -> 'a list -> 'a list -val list_skipn : int -> 'a list -> 'a list -val list_skipn_at_least : int -> 'a list -> 'a list -val list_addn : int -> 'a -> 'a list -> 'a list -val list_prefix_of : 'a list -> 'a list -> bool - -(** [list_drop_prefix p l] returns [t] if [l=p++t] else return [l] *) -val list_drop_prefix : 'a list -> 'a list -> 'a list -val list_drop_last : 'a list -> 'a list - -(** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)] *) -val list_map_append : ('a -> 'b list) -> 'a list -> 'b list -val list_join_map : ('a -> 'b list) -> 'a list -> 'b list - -(** raises [Invalid_argument] if the two lists don't have the same length *) -val list_map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list -val list_share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list - -(** [list_fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]] - where [(e_i,k_i)=f e_{i-1} l_i] *) -val list_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list -val list_fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a -val list_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list -val list_assoc_f : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b - -(** A generic cartesian product: for any operator (**), - [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], - and so on if there are more elements in the lists. *) -val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - -(** [list_cartesians] is an n-ary cartesian product: it iterates - [list_cartesian] over a list of lists. *) -val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list - -(** list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *) -val list_combinations : 'a list list -> 'a list list -val list_combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list - -(** Keep only those products that do not return None *) -val list_cartesian_filter : - ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list -val list_cartesians_filter : - ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list - -val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b -val list_factorize_left : ('a * 'b) list -> ('a * 'b list) list +(** {6 Sets. } *) -(** {6 Arrays. } *) +module Set : module type of CSet -val array_compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int -val array_equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool -val array_exists : ('a -> bool) -> 'a array -> bool -val array_for_all : ('a -> bool) -> 'a array -> bool -val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool -val array_for_all3 : ('a -> 'b -> 'c -> bool) -> - 'a array -> 'b array -> 'c array -> bool -val array_for_all4 : ('a -> 'b -> 'c -> 'd -> bool) -> - 'a array -> 'b array -> 'c array -> 'd array -> bool -val array_for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool -val array_find_i : (int -> 'a -> bool) -> 'a array -> int option -val array_hd : 'a array -> 'a -val array_tl : 'a array -> 'a array -val array_last : 'a array -> 'a -val array_cons : 'a -> 'a array -> 'a array -val array_rev : 'a array -> unit -val array_fold_right_i : - (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a -val array_fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a -val array_fold_right2 : - ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c -val array_fold_left2 : - ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a -val array_fold_left3 : - ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a -val array_fold_left2_i : - (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a -val array_fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a -val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b -val array_app_tl : 'a array -> 'a list -> 'a list -val array_list_of_tl : 'a array -> 'a list -val array_map_to_list : ('a -> 'b) -> 'a array -> 'b list -val array_chop : int -> 'a array -> 'a array * 'a array -val array_smartmap : ('a -> 'a) -> 'a array -> 'a array -val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array -val array_map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array -val array_map3 : - ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array -val array_map_left : ('a -> 'b) -> 'a array -> 'b array -val array_map_left_pair : ('a -> 'b) -> 'a array -> ('c -> 'd) -> 'c array -> - 'b array * 'd array -val array_iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit -val array_fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c -val array_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array -val array_fold_map2' : - ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c -val array_distinct : 'a array -> bool -val array_union_map : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b -val array_rev_to_list : 'a array -> 'a list -val array_filter_along : ('a -> bool) -> 'a list -> 'b array -> 'b array -val array_filter_with : bool list -> 'a array -> 'a array +(** {6 Maps. } *) + +module Map : module type of CMap + +(** {6 Stacks.} *) + +module Stack : module type of CStack (** {6 Streams. } *) @@ -314,7 +87,7 @@ val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b val const : 'a -> 'b -> 'a val iterate : ('a -> 'a) -> int -> 'a -> 'a val repeat : int -> ('a -> unit) -> 'a -> unit -val iterate_for : int -> int -> (int -> 'a -> 'a) -> 'a -> 'a +val app_opt : ('a -> 'a) option -> 'a -> 'a (** {6 Delayed computations. } *) @@ -322,90 +95,18 @@ type 'a delayed = unit -> 'a val delayed_force : 'a delayed -> 'a -(** {6 Misc. } *) - -type ('a,'b) union = Inl of 'a | Inr of 'b - -module Intset : Set.S with type elt = int - -module Intmap : Map.S with type key = int - -val intmap_in_dom : int -> 'a Intmap.t -> bool -val intmap_to_list : 'a Intmap.t -> (int * 'a) list -val intmap_inv : 'a Intmap.t -> 'a -> int list - -val interval : int -> int -> int list - - -(** In [map_succeed f l] an element [a] is removed if [f a] raises - [Failure _] otherwise behaves as [List.map f l] *) +(** {6 Enriched exceptions} *) -val map_succeed : ('a -> 'b) -> 'a list -> 'b list +type iexn = Exninfo.iexn -(** {6 Pretty-printing. } *) +val iraise : iexn -> 'a -val pr_spc : unit -> std_ppcmds -val pr_fnl : unit -> std_ppcmds -val pr_int : int -> std_ppcmds -val pr_str : string -> std_ppcmds -val pr_comma : unit -> std_ppcmds -val pr_semicolon : unit -> std_ppcmds -val pr_bar : unit -> std_ppcmds -val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds -val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds -val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds -val nth : int -> std_ppcmds - -val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds - -(** unlike all other functions below, [prlist] works lazily. - if a strict behavior is needed, use [prlist_strict] instead. *) -val prlist_strict : ('a -> std_ppcmds) -> 'a list -> std_ppcmds -val prlist_with_sep : - (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b list -> std_ppcmds -val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds -val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds -val prvect_with_sep : - (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds -val prvecti_with_sep : - (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds -val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds -val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds -val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds -val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds -val surround : std_ppcmds -> std_ppcmds - -(** {6 Memoization. } *) - -(** General comments on memoization: - - cache is created whenever the function is supplied (because of - ML's polymorphic value restriction). - - cache is never flushed (unless the memoized fun is GC'd) - - One cell memory: memorizes only the last call *) -val memo1_1 : ('a -> 'b) -> ('a -> 'b) -val memo1_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c) - -(** with custom equality (used to deal with various arities) *) -val memo1_eq : ('a -> 'a -> bool) -> ('a -> 'b) -> ('a -> 'b) - -(** Memorizes the last [n] distinct calls. Efficient only for small [n]. *) -val memon_eq : ('a -> 'a -> bool) -> int -> ('a -> 'b) -> ('a -> 'b) - -(** {6 Size of an ocaml value (in words, bytes and kilobytes). } *) - -val size_w : 'a -> int -val size_b : 'a -> int -val size_kb : 'a -> int - -(** {6 Total size of the allocated ocaml heap. } *) +(** {6 Misc. } *) -val heap_size : unit -> int -val heap_size_kb : unit -> int +type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b +(** Union type *) -(** {6 ... } *) -(** Coq interruption: set the following boolean reference to interrupt Coq - (it eventually raises [Break], simulating a Ctrl-C) *) +val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union -val interrupt : bool ref -val check_for_interrupt : unit -> unit +type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a +(** Used for browsable-until structures. *) diff --git a/lib/xml_datatype.mli b/lib/xml_datatype.mli new file mode 100644 index 00000000..f61ba032 --- /dev/null +++ b/lib/xml_datatype.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** ['a gxml] is the type for semi-structured documents. They generalize + XML by allowing any kind of attributes. *) +type 'a gxml = + | Element of (string * 'a * 'a gxml list) + | PCData of string + +(** [xml] is a semi-structured documents where attributes are association + lists from string to string. *) +type xml = (string * string) list gxml + + diff --git a/lib/xml_lexer.mli b/lib/xml_lexer.mli index a1ca0576..e61cb055 100644 --- a/lib/xml_lexer.mli +++ b/lib/xml_lexer.mli @@ -38,7 +38,7 @@ type token = type pos = int * int * int * int val init : Lexing.lexbuf -> unit -val close : Lexing.lexbuf -> unit +val close : unit -> unit val token : Lexing.lexbuf -> token val pos : Lexing.lexbuf -> pos -val restore : pos -> unit
\ No newline at end of file +val restore : pos -> unit diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll index 5b06e720..a33be9da 100644 --- a/lib/xml_lexer.mll +++ b/lib/xml_lexer.mll @@ -20,24 +20,24 @@ open Lexing type error = - | EUnterminatedComment - | EUnterminatedString - | EIdentExpected - | ECloseExpected - | ENodeExpected - | EAttributeNameExpected - | EAttributeValueExpected - | EUnterminatedEntity + | EUnterminatedComment + | EUnterminatedString + | EIdentExpected + | ECloseExpected + | ENodeExpected + | EAttributeNameExpected + | EAttributeValueExpected + | EUnterminatedEntity exception Error of error type pos = int * int * int * int type token = - | Tag of string * (string * string) list * bool - | PCData of string - | Endtag of string - | Eof + | Tag of string * (string * string) list * bool + | PCData of string + | Endtag of string + | Eof let last_pos = ref 0 and current_line = ref 0 @@ -48,39 +48,40 @@ let tmp = Buffer.create 200 let idents = Hashtbl.create 0 let _ = begin - Hashtbl.add idents "gt;" ">"; - Hashtbl.add idents "lt;" "<"; - Hashtbl.add idents "amp;" "&"; - Hashtbl.add idents "apos;" "'"; - Hashtbl.add idents "quot;" "\""; + Hashtbl.add idents "nbsp;" " "; + Hashtbl.add idents "gt;" ">"; + Hashtbl.add idents "lt;" "<"; + Hashtbl.add idents "amp;" "&"; + Hashtbl.add idents "apos;" "'"; + Hashtbl.add idents "quot;" "\""; end let init lexbuf = - current_line := 1; - current_line_start := lexeme_start lexbuf; - last_pos := !current_line_start + current_line := 1; + current_line_start := lexeme_start lexbuf; + last_pos := !current_line_start let close lexbuf = - Buffer.reset tmp + Buffer.reset tmp let pos lexbuf = - !current_line , !current_line_start , - !last_pos , - lexeme_start lexbuf + !current_line , !current_line_start , + !last_pos , + lexeme_start lexbuf let restore (cl,cls,lp,_) = - current_line := cl; - current_line_start := cls; - last_pos := lp + current_line := cl; + current_line_start := cls; + last_pos := lp let newline lexbuf = - incr current_line; - last_pos := lexeme_end lexbuf; - current_line_start := !last_pos + incr current_line; + last_pos := lexeme_end lexbuf; + current_line_start := !last_pos let error lexbuf e = - last_pos := lexeme_start lexbuf; - raise (Error e) + last_pos := lexeme_start lexbuf; + raise (Error e) } @@ -92,100 +93,100 @@ let entitychar = ['A'-'Z' 'a'-'z'] let pcchar = [^ '\r' '\n' '<' '>' '&'] rule token = parse - | newline | (newline break) | break - { - newline lexbuf; + | newline | (newline break) | break + { + newline lexbuf; PCData "\n" - } - | "<!--" - { - last_pos := lexeme_start lexbuf; - comment lexbuf; - token lexbuf - } - | "<?" - { - last_pos := lexeme_start lexbuf; - header lexbuf; - token lexbuf; - } - | '<' space* '/' space* - { - last_pos := lexeme_start lexbuf; - let tag = ident_name lexbuf in - ignore_spaces lexbuf; - close_tag lexbuf; - Endtag tag - } - | '<' space* - { - last_pos := lexeme_start lexbuf; - let tag = ident_name lexbuf in - ignore_spaces lexbuf; - let attribs, closed = attributes lexbuf in - Tag(tag, attribs, closed) - } - | "&#" - { - last_pos := lexeme_start lexbuf; - Buffer.reset tmp; - Buffer.add_string tmp (lexeme lexbuf); - PCData (pcdata lexbuf) - } - | '&' - { - last_pos := lexeme_start lexbuf; - Buffer.reset tmp; - Buffer.add_string tmp (entity lexbuf); - PCData (pcdata lexbuf) - } - | pcchar+ - { - last_pos := lexeme_start lexbuf; - Buffer.reset tmp; - Buffer.add_string tmp (lexeme lexbuf); - PCData (pcdata lexbuf) - } - | eof { Eof } - | _ - { error lexbuf ENodeExpected } + } + | "<!--" + { + last_pos := lexeme_start lexbuf; + comment lexbuf; + token lexbuf + } + | "<?" + { + last_pos := lexeme_start lexbuf; + header lexbuf; + token lexbuf; + } + | '<' space* '/' space* + { + last_pos := lexeme_start lexbuf; + let tag = ident_name lexbuf in + ignore_spaces lexbuf; + close_tag lexbuf; + Endtag tag + } + | '<' space* + { + last_pos := lexeme_start lexbuf; + let tag = ident_name lexbuf in + ignore_spaces lexbuf; + let attribs, closed = attributes lexbuf in + Tag(tag, attribs, closed) + } + | "&#" + { + last_pos := lexeme_start lexbuf; + Buffer.reset tmp; + Buffer.add_string tmp (lexeme lexbuf); + PCData (pcdata lexbuf) + } + | '&' + { + last_pos := lexeme_start lexbuf; + Buffer.reset tmp; + Buffer.add_string tmp (entity lexbuf); + PCData (pcdata lexbuf) + } + | pcchar+ + { + last_pos := lexeme_start lexbuf; + Buffer.reset tmp; + Buffer.add_string tmp (lexeme lexbuf); + PCData (pcdata lexbuf) + } + | eof { Eof } + | _ + { error lexbuf ENodeExpected } and ignore_spaces = parse | newline | (newline break) | break - { - newline lexbuf; - ignore_spaces lexbuf - } - | space + - { ignore_spaces lexbuf } - | "" - { () } + { + newline lexbuf; + ignore_spaces lexbuf + } + | space + + { ignore_spaces lexbuf } + | "" + { () } and comment = parse | newline | (newline break) | break - { - newline lexbuf; - comment lexbuf - } - | "-->" - { () } - | eof - { raise (Error EUnterminatedComment) } - | _ - { comment lexbuf } + { + newline lexbuf; + comment lexbuf + } + | "-->" + { () } + | eof + { raise (Error EUnterminatedComment) } + | _ + { comment lexbuf } and header = parse | newline | (newline break) | break - { - newline lexbuf; - header lexbuf - } - | "?>" - { () } - | eof - { error lexbuf ECloseExpected } - | _ - { header lexbuf } + { + newline lexbuf; + header lexbuf + } + | "?>" + { () } + | eof + { error lexbuf ECloseExpected } + | _ + { header lexbuf } and pcdata = parse | newline | (newline break) | break @@ -194,112 +195,112 @@ and pcdata = parse newline lexbuf; pcdata lexbuf } - | pcchar+ - { - Buffer.add_string tmp (lexeme lexbuf); - pcdata lexbuf - } - | "&#" - { - Buffer.add_string tmp (lexeme lexbuf); - pcdata lexbuf; - } - | '&' - { - Buffer.add_string tmp (entity lexbuf); - pcdata lexbuf - } - | "" - { Buffer.contents tmp } + | pcchar+ + { + Buffer.add_string tmp (lexeme lexbuf); + pcdata lexbuf + } + | "&#" + { + Buffer.add_string tmp (lexeme lexbuf); + pcdata lexbuf; + } + | '&' + { + Buffer.add_string tmp (entity lexbuf); + pcdata lexbuf + } + | "" + { Buffer.contents tmp } and entity = parse - | entitychar+ ';' - { - let ident = lexeme lexbuf in - try - Hashtbl.find idents (String.lowercase ident) - with - Not_found -> "&" ^ ident - } - | _ | eof - { raise (Error EUnterminatedEntity) } + | entitychar+ ';' + { + let ident = lexeme lexbuf in + try + Hashtbl.find idents (String.lowercase ident) + with + Not_found -> "&" ^ ident + } + | _ | eof + { raise (Error EUnterminatedEntity) } and ident_name = parse - | identchar+ - { lexeme lexbuf } - | _ | eof - { error lexbuf EIdentExpected } + | identchar+ + { lexeme lexbuf } + | _ | eof + { error lexbuf EIdentExpected } and close_tag = parse - | '>' - { () } - | _ | eof - { error lexbuf ECloseExpected } + | '>' + { () } + | _ | eof + { error lexbuf ECloseExpected } and attributes = parse - | '>' - { [], false } - | "/>" - { [], true } - | "" (* do not read a char ! *) - { - let key = attribute lexbuf in - let data = attribute_data lexbuf in - ignore_spaces lexbuf; - let others, closed = attributes lexbuf in - (key, data) :: others, closed - } + | '>' + { [], false } + | "/>" + { [], true } + | "" (* do not read a char ! *) + { + let key = attribute lexbuf in + let data = attribute_data lexbuf in + ignore_spaces lexbuf; + let others, closed = attributes lexbuf in + (key, data) :: others, closed + } and attribute = parse - | identchar+ - { lexeme lexbuf } - | _ | eof - { error lexbuf EAttributeNameExpected } + | identchar+ + { lexeme lexbuf } + | _ | eof + { error lexbuf EAttributeNameExpected } and attribute_data = parse - | space* '=' space* '"' - { - Buffer.reset tmp; - last_pos := lexeme_end lexbuf; - dq_string lexbuf - } - | space* '=' space* '\'' - { - Buffer.reset tmp; - last_pos := lexeme_end lexbuf; - q_string lexbuf - } - | _ | eof - { error lexbuf EAttributeValueExpected } + | space* '=' space* '"' + { + Buffer.reset tmp; + last_pos := lexeme_end lexbuf; + dq_string lexbuf + } + | space* '=' space* '\'' + { + Buffer.reset tmp; + last_pos := lexeme_end lexbuf; + q_string lexbuf + } + | _ | eof + { error lexbuf EAttributeValueExpected } and dq_string = parse - | '"' - { Buffer.contents tmp } - | '\\' [ '"' '\\' ] - { - Buffer.add_char tmp (lexeme_char lexbuf 1); - dq_string lexbuf - } - | eof - { raise (Error EUnterminatedString) } - | _ - { - Buffer.add_char tmp (lexeme_char lexbuf 0); - dq_string lexbuf - } + | '"' + { Buffer.contents tmp } + | '\\' [ '"' '\\' ] + { + Buffer.add_char tmp (lexeme_char lexbuf 1); + dq_string lexbuf + } + | eof + { raise (Error EUnterminatedString) } + | _ + { + Buffer.add_char tmp (lexeme_char lexbuf 0); + dq_string lexbuf + } and q_string = parse - | '\'' - { Buffer.contents tmp } - | '\\' [ '\'' '\\' ] - { - Buffer.add_char tmp (lexeme_char lexbuf 1); - q_string lexbuf - } - | eof - { raise (Error EUnterminatedString) } - | _ - { - Buffer.add_char tmp (lexeme_char lexbuf 0); - q_string lexbuf - } + | '\'' + { Buffer.contents tmp } + | '\\' [ '\'' '\\' ] + { + Buffer.add_char tmp (lexeme_char lexbuf 1); + q_string lexbuf + } + | eof + { raise (Error EUnterminatedString) } + | _ + { + Buffer.add_char tmp (lexeme_char lexbuf 0); + q_string lexbuf + } diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml index 600796f7..8db3f9e8 100644 --- a/lib/xml_parser.ml +++ b/lib/xml_parser.ml @@ -19,30 +19,29 @@ *) open Printf +open Xml_datatype -type xml = - | Element of (string * (string * string) list * xml list) - | PCData of string +type xml = Xml_datatype.xml type error_pos = { - eline : int; - eline_start : int; - emin : int; - emax : int; + eline : int; + eline_start : int; + emin : int; + emax : int; } type error_msg = - | UnterminatedComment - | UnterminatedString - | UnterminatedEntity - | IdentExpected - | CloseExpected - | NodeExpected - | AttributeNameExpected - | AttributeValueExpected - | EndOfTagExpected of string - | EOFExpected - | Empty + | UnterminatedComment + | UnterminatedString + | UnterminatedEntity + | IdentExpected + | CloseExpected + | NodeExpected + | AttributeNameExpected + | AttributeValueExpected + | EndOfTagExpected of string + | EOFExpected + | Empty type error = error_msg * error_pos @@ -51,21 +50,16 @@ exception Error of error exception File_not_found of string type t = { - mutable check_eof : bool; - mutable concat_pcdata : bool; + mutable check_eof : bool; + mutable concat_pcdata : bool; + source : Lexing.lexbuf; + stack : Xml_lexer.token Stack.t; } -type source = - | SFile of string - | SChannel of in_channel - | SString of string - | SLexbuf of Lexing.lexbuf - -type state = { - source : Lexing.lexbuf; - stack : Xml_lexer.token Stack.t; - xparser : t; -} +type source = + | SChannel of in_channel + | SString of string + | SLexbuf of Lexing.lexbuf exception Internal_error of error_msg exception NoMoreData @@ -86,152 +80,153 @@ let is_blank s = !i = len let _raises e f = - xml_error := e; - file_not_found := f - -let make () = - { - check_eof = true; - concat_pcdata = true; - } + xml_error := e; + file_not_found := f + +let make source = + let source = match source with + | SChannel chan -> Lexing.from_channel chan + | SString s -> Lexing.from_string s + | SLexbuf lexbuf -> lexbuf + in + let () = Xml_lexer.init source in + { + check_eof = false; + concat_pcdata = true; + source = source; + stack = Stack.create (); + } let check_eof p v = p.check_eof <- v -let concat_pcdata p v = p.concat_pcdata <- v let pop s = - try - Stack.pop s.stack - with - Stack.Empty -> - Xml_lexer.token s.source + try + Stack.pop s.stack + with + Stack.Empty -> + Xml_lexer.token s.source let push t s = - Stack.push t s.stack + Stack.push t s.stack let canonicalize l = let has_elt = List.exists (function Element _ -> true | _ -> false) l in if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l else l -let rec read_node s = - match pop s with - | Xml_lexer.PCData s -> PCData s - | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, []) - | Xml_lexer.Tag (tag, attr, false) -> - let elements = read_elems tag s in - Element (tag, attr, canonicalize elements) - | t -> - push t s; - raise NoMoreData -and - read_elems tag s = - let elems = ref [] in - (try - while true do - let node = read_node s in - match node, !elems with - | PCData c , (PCData c2) :: q -> - elems := PCData (c2 ^ c) :: q - | _, l -> - elems := node :: l - done - with - NoMoreData -> ()); - match pop s with - | Xml_lexer.Endtag s when s = tag -> List.rev !elems - | t -> raise (Internal_error (EndOfTagExpected tag)) - -let rec read_xml s = - let node = read_node s in - match node with - | Element _ -> node - | PCData c -> - if is_blank c then read_xml s - else raise (Xml_lexer.Error Xml_lexer.ENodeExpected) +let rec read_xml do_not_canonicalize s = + let rec read_node s = + match pop s with + | Xml_lexer.PCData s -> PCData s + | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, []) + | Xml_lexer.Tag (tag, attr, false) -> + let elements = read_elems tag s in + let elements = + if do_not_canonicalize then elements else canonicalize elements + in + Element (tag, attr, elements) + | t -> + push t s; + raise NoMoreData + + and read_elems tag s = + let elems = ref [] in + (try + while true do + let node = read_node s in + match node, !elems with + | PCData c , (PCData c2) :: q -> + elems := PCData (c2 ^ c) :: q + | _, l -> + elems := node :: l + done + with + NoMoreData -> ()); + match pop s with + | Xml_lexer.Endtag s when s = tag -> List.rev !elems + | t -> raise (Internal_error (EndOfTagExpected tag)) + in + match read_node s with + | (Element _) as node -> + node + | PCData c -> + if is_blank c then + read_xml do_not_canonicalize s + else + raise (Xml_lexer.Error Xml_lexer.ENodeExpected) let convert = function - | Xml_lexer.EUnterminatedComment -> UnterminatedComment - | Xml_lexer.EUnterminatedString -> UnterminatedString - | Xml_lexer.EIdentExpected -> IdentExpected - | Xml_lexer.ECloseExpected -> CloseExpected - | Xml_lexer.ENodeExpected -> NodeExpected - | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected - | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected - | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity - -let error_of_exn stk = function - | NoMoreData when Stack.pop stk = Xml_lexer.Eof -> Empty + | Xml_lexer.EUnterminatedComment -> UnterminatedComment + | Xml_lexer.EUnterminatedString -> UnterminatedString + | Xml_lexer.EIdentExpected -> IdentExpected + | Xml_lexer.ECloseExpected -> CloseExpected + | Xml_lexer.ENodeExpected -> NodeExpected + | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected + | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected + | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity + +let error_of_exn xparser = function + | NoMoreData when pop xparser = Xml_lexer.Eof -> Empty | NoMoreData -> NodeExpected | Internal_error e -> e | Xml_lexer.Error e -> convert e - | e -> raise e - -let do_parse xparser source = - let stk = Stack.create() in - try - Xml_lexer.init source; - let s = { source = source; xparser = xparser; stack = stk } in - let x = read_xml s in - if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected); - Xml_lexer.close source; - x - with e when e <> Sys.Break -> - Xml_lexer.close source; - raise (!xml_error (error_of_exn stk e) source) - -let parse p = function - | SChannel ch -> do_parse p (Lexing.from_channel ch) - | SString str -> do_parse p (Lexing.from_string str) - | SLexbuf lex -> do_parse p lex - | SFile fname -> - let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in - try - let x = do_parse p (Lexing.from_channel ch) in - close_in ch; - x - with - reraise -> - close_in ch; - raise reraise - + | e -> + (*let e = Errors.push e in: We do not record backtrace here. *) + raise e + +let do_parse do_not_canonicalize xparser = + try + Xml_lexer.init xparser.source; + let x = read_xml do_not_canonicalize xparser in + if xparser.check_eof && pop xparser <> Xml_lexer.Eof then raise (Internal_error EOFExpected); + Xml_lexer.close (); + x + with any -> + Xml_lexer.close (); + raise (!xml_error (error_of_exn xparser any) xparser.source) + +let parse ?(do_not_canonicalize=false) p = + do_parse do_not_canonicalize p let error_msg = function - | UnterminatedComment -> "Unterminated comment" - | UnterminatedString -> "Unterminated string" - | UnterminatedEntity -> "Unterminated entity" - | IdentExpected -> "Ident expected" - | CloseExpected -> "Element close expected" - | NodeExpected -> "Xml node expected" - | AttributeNameExpected -> "Attribute name expected" - | AttributeValueExpected -> "Attribute value expected" - | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag - | EOFExpected -> "End of file expected" - | Empty -> "Empty" + | UnterminatedComment -> "Unterminated comment" + | UnterminatedString -> "Unterminated string" + | UnterminatedEntity -> "Unterminated entity" + | IdentExpected -> "Ident expected" + | CloseExpected -> "Element close expected" + | NodeExpected -> "Xml node expected" + | AttributeNameExpected -> "Attribute name expected" + | AttributeValueExpected -> "Attribute value expected" + | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag + | EOFExpected -> "End of file expected" + | Empty -> "Empty" let error (msg,pos) = - if pos.emin = pos.emax then - sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) - else - sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start) - + if pos.emin = pos.emax then + sprintf "%s line %d character %d" (error_msg msg) pos.eline + (pos.emin - pos.eline_start) + else + sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline + (pos.emin - pos.eline_start) (pos.emax - pos.eline_start) + let line e = e.eline -let range e = - e.emin - e.eline_start , e.emax - e.eline_start +let range e = + e.emin - e.eline_start , e.emax - e.eline_start let abs_range e = - e.emin , e.emax + e.emin , e.emax let pos source = - let line, lstart, min, max = Xml_lexer.pos source in - { - eline = line; - eline_start = lstart; - emin = min; - emax = max; - } - -let () = _raises (fun x p -> + let line, lstart, min, max = Xml_lexer.pos source in + { + eline = line; + eline_start = lstart; + emin = min; + emax = max; + } + +let () = _raises (fun x p -> (* local cast : Xml.error_msg -> error_msg *) - Error (x, pos p)) - (fun f -> File_not_found f) + Error (x, pos p)) + (fun f -> File_not_found f) diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli index cc9bcd33..cefb4af8 100644 --- a/lib/xml_parser.mli +++ b/lib/xml_parser.mli @@ -27,9 +27,7 @@ (** An Xml node is either [Element (tag-name, attributes, children)] or [PCData text] *) -type xml = - | Element of (string * (string * string) list * xml list) - | PCData of string +type xml = Xml_datatype.xml (** Abstract type for an Xml parser. *) type t @@ -59,7 +57,7 @@ type error_msg = | AttributeValueExpected | EndOfTagExpected of string | EOFExpected - | Empty + | Empty type error = error_msg * error_pos @@ -71,7 +69,7 @@ exception File_not_found of string val error : error -> string (** Get the Xml error message as a string. *) -val error_msg : error_msg -> string +val error_msg : error_msg -> string (** Get the line the error occured at. *) val line : error_pos -> int @@ -85,21 +83,24 @@ val abs_range : error_pos -> int * int val pos : Lexing.lexbuf -> error_pos (** Several kind of resources can contain Xml documents. *) -type source = - | SFile of string - | SChannel of in_channel - | SString of string - | SLexbuf of Lexing.lexbuf +type source = +| SChannel of in_channel +| SString of string +| SLexbuf of Lexing.lexbuf (** This function returns a new parser with default options. *) -val make : unit -> t +val make : source -> t -(** When a Xml document is parsed, the parser will check that the end of the +(** When a Xml document is parsed, the parser may check that the end of the document is reached, so for example parsing ["<A/><B/>"] will fail instead - of returning only the A element. You can turn off this check by setting - [check_eof] to [false] {i (by default, check_eof is true)}. *) + of returning only the A element. You can turn on this check by setting + [check_eof] to [true] {i (by default, check_eof is false, unlike + in the original Xmllight)}. *) val check_eof : t -> bool -> unit (** Once the parser is configurated, you can run the parser on a any kind - of xml document source to parse its contents into an Xml data structure. *) -val parse : t -> source -> xml + of xml document source to parse its contents into an Xml data structure. + + When [do_not_canonicalize] is set, the XML document is given as + is, without trying to remove blank PCDATA elements. *) +val parse : ?do_not_canonicalize:bool -> t -> xml diff --git a/lib/xml_printer.ml b/lib/xml_printer.ml new file mode 100644 index 00000000..eeddd53c --- /dev/null +++ b/lib/xml_printer.ml @@ -0,0 +1,143 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype + +type xml = Xml_datatype.xml + +type target = TChannel of out_channel | TBuffer of Buffer.t + +type t = target + +let make x = x + +let buffer_pcdata tmp text = + let output = Buffer.add_string tmp in + let output' = Buffer.add_char tmp in + let l = String.length text in + for p = 0 to l-1 do + match text.[p] with + | ' ' -> output " "; + | '>' -> output ">" + | '<' -> output "<" + | '&' -> + if p < l - 1 && text.[p + 1] = '#' then + output' '&' + else + output "&" + | '\'' -> output "'" + | '"' -> output """ + | c -> output' c + done + +let buffer_attr tmp (n,v) = + let output = Buffer.add_string tmp in + let output' = Buffer.add_char tmp in + output' ' '; + output n; + output "=\""; + let l = String.length v in + for p = 0 to l - 1 do + match v.[p] with + | '\\' -> output "\\\\" + | '"' -> output "\\\"" + | c -> output' c + done; + output' '"' + +let to_buffer tmp x = + let pcdata = ref false in + let output = Buffer.add_string tmp in + let output' = Buffer.add_char tmp in + let rec loop = function + | Element (tag,alist,[]) -> + output' '<'; + output tag; + List.iter (buffer_attr tmp) alist; + output "/>"; + pcdata := false; + | Element (tag,alist,l) -> + output' '<'; + output tag; + List.iter (buffer_attr tmp) alist; + output' '>'; + pcdata := false; + List.iter loop l; + output "</"; + output tag; + output' '>'; + pcdata := false; + | PCData text -> + if !pcdata then output' ' '; + buffer_pcdata tmp text; + pcdata := true; + in + loop x + +let pcdata_to_string s = + let b = Buffer.create 13 in + buffer_pcdata b s; + Buffer.contents b + +let to_string x = + let b = Buffer.create 200 in + to_buffer b x; + Buffer.contents b + +let to_string_fmt x = + let tmp = Buffer.create 200 in + let output = Buffer.add_string tmp in + let output' = Buffer.add_char tmp in + let rec loop ?(newl=false) tab = function + | Element (tag, alist, []) -> + output tab; + output' '<'; + output tag; + List.iter (buffer_attr tmp) alist; + output "/>"; + if newl then output' '\n'; + | Element (tag, alist, [PCData text]) -> + output tab; + output' '<'; + output tag; + List.iter (buffer_attr tmp) alist; + output ">"; + buffer_pcdata tmp text; + output "</"; + output tag; + output' '>'; + if newl then output' '\n'; + | Element (tag, alist, l) -> + output tab; + output' '<'; + output tag; + List.iter (buffer_attr tmp) alist; + output ">\n"; + List.iter (loop ~newl:true (tab^" ")) l; + output tab; + output "</"; + output tag; + output' '>'; + if newl then output' '\n'; + | PCData text -> + buffer_pcdata tmp text; + if newl then output' '\n'; + in + loop "" x; + Buffer.contents tmp + +let print t xml = + let tmp, flush = match t with + | TChannel oc -> + let b = Buffer.create 200 in + b, (fun () -> Buffer.output_buffer oc b; flush oc) + | TBuffer b -> + b, (fun () -> ()) + in + to_buffer tmp xml; + flush () diff --git a/lib/xml_printer.mli b/lib/xml_printer.mli new file mode 100644 index 00000000..e21eca28 --- /dev/null +++ b/lib/xml_printer.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type xml = Xml_datatype.xml + +type t +type target = TChannel of out_channel | TBuffer of Buffer.t + +val make : target -> t + +(** Print the xml data structure to a source into a compact xml string (without + any user-readable formating ). *) +val print : t -> xml -> unit + +(** Print the xml data structure into a compact xml string (without + any user-readable formating ). *) +val to_string : xml -> string + +(** Print the xml data structure into an user-readable string with + tabs and lines break between different nodes. *) +val to_string_fmt : xml -> string + +(** Print PCDATA as a string by escaping XML entities. *) +val pcdata_to_string : string -> string diff --git a/lib/xml_utils.ml b/lib/xml_utils.ml deleted file mode 100644 index 31003586..00000000 --- a/lib/xml_utils.ml +++ /dev/null @@ -1,223 +0,0 @@ -(* - * Xml Light, an small Xml parser/printer with DTD support. - * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -open Printf -open Xml_parser - -exception Not_element of xml -exception Not_pcdata of xml -exception No_attribute of string - -let default_parser = Xml_parser.make() - -let parse (p:Xml_parser.t) (source:Xml_parser.source) = - (* local cast Xml.xml -> xml *) - (Obj.magic Xml_parser.parse p source : xml) - -let parse_in ch = parse default_parser (Xml_parser.SChannel ch) -let parse_string str = parse default_parser (Xml_parser.SString str) - -let parse_file f = parse default_parser (Xml_parser.SFile f) - -let tag = function - | Element (tag,_,_) -> tag - | x -> raise (Not_element x) - -let pcdata = function - | PCData text -> text - | x -> raise (Not_pcdata x) - -let attribs = function - | Element (_,attr,_) -> attr - | x -> raise (Not_element x) - -let attrib x att = - match x with - | Element (_,attr,_) -> - (try - let att = String.lowercase att in - snd (List.find (fun (n,_) -> String.lowercase n = att) attr) - with - Not_found -> - raise (No_attribute att)) - | x -> - raise (Not_element x) - -let children = function - | Element (_,_,clist) -> clist - | x -> raise (Not_element x) - -(*let enum = function - | Element (_,_,clist) -> List.to_enum clist - | x -> raise (Not_element x) -*) - -let iter f = function - | Element (_,_,clist) -> List.iter f clist - | x -> raise (Not_element x) - -let map f = function - | Element (_,_,clist) -> List.map f clist - | x -> raise (Not_element x) - -let fold f v = function - | Element (_,_,clist) -> List.fold_left f v clist - | x -> raise (Not_element x) - -let tmp = Buffer.create 200 - -let buffer_pcdata text = - let l = String.length text in - for p = 0 to l-1 do - match text.[p] with - | '>' -> Buffer.add_string tmp ">" - | '<' -> Buffer.add_string tmp "<" - | '&' -> - if p < l-1 && text.[p+1] = '#' then - Buffer.add_char tmp '&' - else - Buffer.add_string tmp "&" - | '\'' -> Buffer.add_string tmp "'" - | '"' -> Buffer.add_string tmp """ - | c -> Buffer.add_char tmp c - done - -let print_pcdata chan text = - let l = String.length text in - for p = 0 to l-1 do - match text.[p] with - | '>' -> Printf.fprintf chan ">" - | '<' -> Printf.fprintf chan "<" - | '&' -> - if p < l-1 && text.[p+1] = '#' then - Printf.fprintf chan "&" - else - Printf.fprintf chan "&" - | '\'' -> Printf.fprintf chan "'" - | '"' -> Printf.fprintf chan """ - | c -> Printf.fprintf chan "%c" c - done - -let buffer_attr (n,v) = - Buffer.add_char tmp ' '; - Buffer.add_string tmp n; - Buffer.add_string tmp "=\""; - let l = String.length v in - for p = 0 to l-1 do - match v.[p] with - | '\\' -> Buffer.add_string tmp "\\\\" - | '"' -> Buffer.add_string tmp "\\\"" - | c -> Buffer.add_char tmp c - done; - Buffer.add_char tmp '"' - -let rec print_attr chan (n, v) = - Printf.fprintf chan " %s=\"" n; - let l = String.length v in - for p = 0 to l-1 do - match v.[p] with - | '\\' -> Printf.fprintf chan "\\\\" - | '"' -> Printf.fprintf chan "\\\"" - | c -> Printf.fprintf chan "%c" c - done; - Printf.fprintf chan "\"" - -let print_attrs chan l = List.iter (print_attr chan) l - -let rec print_xml chan = function -| Element (tag, alist, []) -> - Printf.fprintf chan "<%s%a/>" tag print_attrs alist; -| Element (tag, alist, l) -> - Printf.fprintf chan "<%s%a>%a</%s>" tag print_attrs alist - (fun chan -> List.iter (print_xml chan)) l tag -| PCData text -> - print_pcdata chan text - -let to_string x = - let pcdata = ref false in - let rec loop = function - | Element (tag,alist,[]) -> - Buffer.add_char tmp '<'; - Buffer.add_string tmp tag; - List.iter buffer_attr alist; - Buffer.add_string tmp "/>"; - pcdata := false; - | Element (tag,alist,l) -> - Buffer.add_char tmp '<'; - Buffer.add_string tmp tag; - List.iter buffer_attr alist; - Buffer.add_char tmp '>'; - pcdata := false; - List.iter loop l; - Buffer.add_string tmp "</"; - Buffer.add_string tmp tag; - Buffer.add_char tmp '>'; - pcdata := false; - | PCData text -> - if !pcdata then Buffer.add_char tmp ' '; - buffer_pcdata text; - pcdata := true; - in - Buffer.reset tmp; - loop x; - let s = Buffer.contents tmp in - Buffer.reset tmp; - s - -let to_string_fmt x = - let rec loop ?(newl=false) tab = function - | Element (tag,alist,[]) -> - Buffer.add_string tmp tab; - Buffer.add_char tmp '<'; - Buffer.add_string tmp tag; - List.iter buffer_attr alist; - Buffer.add_string tmp "/>"; - if newl then Buffer.add_char tmp '\n'; - | Element (tag,alist,[PCData text]) -> - Buffer.add_string tmp tab; - Buffer.add_char tmp '<'; - Buffer.add_string tmp tag; - List.iter buffer_attr alist; - Buffer.add_string tmp ">"; - buffer_pcdata text; - Buffer.add_string tmp "</"; - Buffer.add_string tmp tag; - Buffer.add_char tmp '>'; - if newl then Buffer.add_char tmp '\n'; - | Element (tag,alist,l) -> - Buffer.add_string tmp tab; - Buffer.add_char tmp '<'; - Buffer.add_string tmp tag; - List.iter buffer_attr alist; - Buffer.add_string tmp ">\n"; - List.iter (loop ~newl:true (tab^" ")) l; - Buffer.add_string tmp tab; - Buffer.add_string tmp "</"; - Buffer.add_string tmp tag; - Buffer.add_char tmp '>'; - if newl then Buffer.add_char tmp '\n'; - | PCData text -> - buffer_pcdata text; - if newl then Buffer.add_char tmp '\n'; - in - Buffer.reset tmp; - loop "" x; - let s = Buffer.contents tmp in - Buffer.reset tmp; - s diff --git a/lib/xml_utils.mli b/lib/xml_utils.mli deleted file mode 100644 index 4a4a1309..00000000 --- a/lib/xml_utils.mli +++ /dev/null @@ -1,93 +0,0 @@ -(* - * Xml Light, an small Xml parser/printer with DTD support. - * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com) - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -(** Xml Light - - Xml Light is a minimal Xml parser & printer for OCaml. - It provide few functions to parse a basic Xml document into - an OCaml data structure and to print back the data structures - to an Xml document. - - Xml Light has also support for {b DTD} (Document Type Definition). - - {i (c)Copyright 2002-2003 Nicolas Cannasse} -*) - -open Xml_parser - -(** {6 Xml Functions} *) - -exception Not_element of xml -exception Not_pcdata of xml -exception No_attribute of string - -(** [tag xdata] returns the tag value of the xml node. - Raise {!Xml.Not_element} if the xml is not an element *) -val tag : xml -> string - -(** [pcdata xdata] returns the PCData value of the xml node. - Raise {!Xml.Not_pcdata} if the xml is not a PCData *) -val pcdata : xml -> string - -(** [attribs xdata] returns the attribute list of the xml node. - First string if the attribute name, second string is attribute value. - Raise {!Xml.Not_element} if the xml is not an element *) -val attribs : xml -> (string * string) list - -(** [attrib xdata "href"] returns the value of the ["href"] - attribute of the xml node (attribute matching is case-insensitive). - Raise {!Xml.No_attribute} if the attribute does not exists in the node's - attribute list - Raise {!Xml.Not_element} if the xml is not an element *) -val attrib : xml -> string -> string - -(** [children xdata] returns the children list of the xml node - Raise {!Xml.Not_element} if the xml is not an element *) -val children : xml -> xml list - -(*** [enum xdata] returns the children enumeration of the xml node - Raise {!Xml.Not_element} if the xml is not an element *) -(* val enum : xml -> xml Enum.t *) - -(** [iter f xdata] calls f on all children of the xml node. - Raise {!Xml.Not_element} if the xml is not an element *) -val iter : (xml -> unit) -> xml -> unit - -(** [map f xdata] is equivalent to [List.map f (Xml.children xdata)] - Raise {!Xml.Not_element} if the xml is not an element *) -val map : (xml -> 'a) -> xml -> 'a list - -(** [fold f init xdata] is equivalent to - [List.fold_left f init (Xml.children xdata)] - Raise {!Xml.Not_element} if the xml is not an element *) -val fold : ('a -> xml -> 'a) -> 'a -> xml -> 'a - -(** {6 Xml Printing} *) - -(** Print the xml data structure to a channel into a compact xml string (without - any user-readable formating ). *) -val print_xml : out_channel -> xml -> unit - -(** Print the xml data structure into a compact xml string (without - any user-readable formating ). *) -val to_string : xml -> string - -(** Print the xml data structure into an user-readable string with - tabs and lines break between different nodes. *) -val to_string_fmt : xml -> string |