From 164c6861860e6b52818c031f901ffeff91fca16a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 26 Jan 2016 16:56:33 +0100 Subject: Imported Upstream version 8.5 --- lib/aux_file.ml | 2 +- lib/aux_file.mli | 2 +- lib/bigint.ml | 2 +- lib/bigint.mli | 2 +- lib/cMap.ml | 4 +-- lib/cMap.mli | 4 +-- lib/cSet.ml | 2 +- lib/cSet.mli | 2 +- lib/cSig.mli | 31 +++++++++++++++++++ lib/cString.ml | 2 +- lib/cString.mli | 2 +- lib/cThread.ml | 2 +- lib/cThread.mli | 2 +- lib/cUnix.ml | 2 +- lib/cUnix.mli | 2 +- lib/canary.ml | 2 +- lib/canary.mli | 2 +- lib/clib.mllib | 4 +-- lib/control.ml | 2 +- lib/control.mli | 2 +- lib/deque.ml | 2 +- lib/deque.mli | 2 +- lib/dyn.ml | 2 +- lib/dyn.mli | 2 +- lib/envars.ml | 7 +++-- lib/envars.mli | 2 +- lib/ephemeron.ml | 2 +- lib/ephemeron.mli | 2 +- lib/explore.ml | 2 +- lib/explore.mli | 2 +- lib/feedback.ml | 2 +- lib/feedback.mli | 2 +- lib/flags.ml | 4 ++- lib/flags.mli | 4 ++- lib/future.ml | 2 +- lib/future.mli | 2 +- lib/genarg.ml | 2 +- lib/genarg.mli | 2 +- lib/hMap.ml | 2 +- lib/hMap.mli | 2 +- lib/hashcons.ml | 2 +- lib/hashcons.mli | 2 +- lib/hashset.ml | 2 +- lib/hashset.mli | 2 +- lib/heap.ml | 2 +- lib/heap.mli | 2 +- lib/hook.ml | 2 +- lib/hook.mli | 2 +- lib/iStream.ml | 2 +- lib/iStream.mli | 2 +- lib/int.ml | 2 +- lib/int.mli | 2 +- lib/loc.ml | 4 +-- lib/loc.mli | 2 +- lib/option.ml | 2 +- lib/option.mli | 2 +- lib/pp.ml | 2 +- lib/pp.mli | 2 +- lib/pp_control.ml | 2 +- lib/pp_control.mli | 2 +- lib/ppstyle.ml | 2 +- lib/ppstyle.mli | 2 +- lib/predicate.ml | 9 +++--- lib/predicate.mli | 85 ++++++++++++++++++++++++++++++--------------------- lib/profile.ml | 2 +- lib/profile.mli | 2 +- lib/remoteCounter.ml | 2 +- lib/remoteCounter.mli | 2 +- lib/richpp.ml | 2 +- lib/richpp.mli | 2 +- lib/rtree.ml | 2 +- lib/rtree.mli | 2 +- lib/serialize.ml | 2 +- lib/serialize.mli | 2 +- lib/spawn.ml | 10 ++++-- lib/spawn.mli | 2 +- lib/system.ml | 84 ++++++++++++++++++++++++++++++++++++-------------- lib/system.mli | 4 ++- lib/terminal.ml | 2 +- lib/terminal.mli | 2 +- lib/trie.ml | 2 +- lib/trie.mli | 2 +- lib/unicode.mli | 2 +- lib/unionfind.ml | 2 +- lib/unionfind.mli | 2 +- lib/util.mli | 2 +- lib/xml_datatype.mli | 2 +- lib/xml_printer.ml | 2 +- lib/xml_printer.mli | 2 +- 89 files changed, 253 insertions(+), 153 deletions(-) (limited to 'lib') diff --git a/lib/aux_file.ml b/lib/aux_file.ml index 5dedb0d0..f7bd81f8 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -> 'a t -> 'a t val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t diff --git a/lib/cMap.mli b/lib/cMap.mli index 23d3801e..2f243da8 100644 --- a/lib/cMap.mli +++ b/lib/cMap.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool + val mem: key -> 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val singleton: key -> 'a -> 'a t + val remove: key -> 'a t -> 'a t + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all: (key -> 'a -> bool) -> 'a t -> bool + val exists: (key -> 'a -> bool) -> 'a t -> bool + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val bindings: 'a t -> (key * 'a) list + val min_binding: 'a t -> (key * 'a) + val max_binding: 'a t -> (key * 'a) + val choose: 'a t -> (key * 'a) + val split: key -> 'a t -> 'a t * 'a option * 'a t + val find: key -> 'a t -> 'a + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t +end diff --git a/lib/cString.ml b/lib/cString.ml index e9006860..0c2ed2e7 100644 --- a/lib/cString.ml +++ b/lib/cString.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* @@ -99,7 +101,8 @@ let _ = (** [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. *) + If the check fails, then [oth ()] is evaluated. + Using file system equality seems well enough for this heuristic *) let check_file_else ~dir ~file oth = let path = if Coq_config.local then coqroot else coqroot / dir in if Sys.file_exists (path / file) then path else oth () diff --git a/lib/envars.mli b/lib/envars.mli index b62b9f28..d95b6f09 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* EltSet.subset p1 p2 @@ -91,6 +91,7 @@ module Make(Ord: OrderedType) = | ((false,p1),(true,n2)) -> EltSet.is_empty (EltSet.inter p1 n2) | ((true,_),(false,_)) -> false + (* assumes the set is infinite *) let equal (b1,s1) (b2,s2) = b1=b2 && EltSet.equal s1 s2 diff --git a/lib/predicate.mli b/lib/predicate.mli index bcc89e72..cee3b0bd 100644 --- a/lib/predicate.mli +++ b/lib/predicate.mli @@ -1,67 +1,84 @@ +(** Infinite sets over a chosen [OrderedType]. -(** Module [Pred]: sets over infinite ordered types with complement. *) - -(** This module implements the set data structure, given a total ordering - function over the set elements. All operations over sets - are purely applicative (no side-effects). - The implementation uses the Set library. *) + All operations over sets are purely applicative (no side-effects). + *) +(** Input signature of the functor [Make]. *) module type OrderedType = sig type t - val compare: t -> t -> int + (** The type of the elements in the set. + + The chosen [t] {b must be infinite}. *) + + val compare : t -> t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that: + - [f e1 e2] is zero if the elements [e1] and [e2] are equal, + - [f e1 e2] is strictly negative if [e1] is smaller than [e2], + - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + *) end - (** The input signature of the functor [Pred.Make]. - [t] is the type of the set elements. - [compare] is a total ordering function over the set elements. - This is a two-argument function [f] such that - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is - the generic structural comparison function [compare]. *) module type S = sig type elt - (** The type of the set elements. *) + (** The type of the elements in the set. *) + type t - (** The type of sets. *) + (** The type of sets. *) + val empty: t - (** The empty set. *) + (** The empty set. *) + val full: t - (** The whole type. *) + (** The set of all elements (of type [elm]). *) + val is_empty: t -> bool - (** Test whether a set is empty or not. *) + (** Test whether a set is empty or not. *) + val is_full: t -> bool - (** Test whether a set contains the whole type or not. *) + (** Test whether a set contains the whole type or not. *) + val mem: elt -> t -> bool - (** [mem x s] tests whether [x] belongs to the set [s]. *) + (** [mem x s] tests whether [x] belongs to the set [s]. *) + val singleton: elt -> t - (** [singleton x] returns the one-element set containing only [x]. *) + (** [singleton x] returns the one-element set containing only [x]. *) + val add: elt -> t -> t - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], then [s] is returned unchanged. *) + val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) + except [x]. If [x] was not in [s], then [s] is returned unchanged. *) + val union: t -> t -> t + (** Set union. *) + val inter: t -> t -> t + (** Set intersection. *) + val diff: t -> t -> t + (** Set difference. *) + val complement: t -> t - (** Union, intersection, difference and set complement. *) + (** Set complement. *) + val equal: t -> t -> bool - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) + the set [s2]. *) + val elements: t -> bool * elt list (** Gives a finite representation of the predicate: if the boolean is false, then the predicate is given in extension. if it is true, then the complement is given *) end -module Make(Ord: OrderedType): (S with type elt = Ord.t) - (** Functor building an implementation of the set structure - given a totally ordered type. *) +(** The [Make] functor constructs an implementation for any [OrderedType]. *) +module Make (Ord : OrderedType) : (S with type elt = Ord.t) diff --git a/lib/profile.ml b/lib/profile.ml index c55064ca..2350cd43 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* prerr_endline ("kill: "^Printexc.to_string e) end @@ -247,13 +249,15 @@ 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) = +let kill ({ pid = unixpid; oob_req; oob_resp; 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; + close_in_noerr oob_resp; + close_out_noerr oob_req; if Sys.os_type = "Unix" then Unix.kill unixpid 9; with e -> prerr_endline ("kill: "^Printexc.to_string e) end diff --git a/lib/spawn.mli b/lib/spawn.mli index 8022573b..9b86b095 100644 --- a/lib/spawn.mli +++ b/lib/spawn.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* false + try Sys.is_directory dir with Sys_error _ -> false let skipped_dirnames = ref ["CVS"; "_darcs"] @@ -31,28 +30,62 @@ let all_subdirs ~unix_path:root = let l = ref [] in let add f rel = l := (f, rel) :: !l in let rec traverse dir rel = - let dirh = opendir dir in - try - while true do - let f = readdir dirh in - if ok_dirname f then - let file = Filename.concat dir f in - try - begin match (stat file).st_kind with - | S_DIR -> - let newrel = rel @ [f] in - add file newrel; - traverse file newrel - | _ -> () - end - with Unix_error (e,s1,s2) -> () - done - with End_of_file -> - closedir dirh + Array.iter (fun f -> + if ok_dirname f then + let file = Filename.concat dir f in + if Sys.is_directory file then begin + let newrel = rel @ [f] in + add file newrel; + traverse file newrel + end) + (Sys.readdir dir) in if exists_dir root then traverse root []; List.rev !l +(* Caching directory contents for efficient syntactic equality of file + names even on case-preserving but case-insensitive file systems *) + +module StrMod = struct + type t = string + let compare = compare +end + +module StrMap = Map.Make(StrMod) +module StrSet = Set.Make(StrMod) + +let dirmap = ref StrMap.empty + +let make_dir_table dir = + let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in + Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) + +let exists_in_dir_respecting_case dir bf = + let contents, cached = + try StrMap.find dir !dirmap, true with Not_found -> + let contents = make_dir_table dir in + dirmap := StrMap.add dir contents !dirmap; + contents, false in + StrSet.mem bf contents || + if cached then begin + (* rescan, there is a new file we don't know about *) + let contents = make_dir_table dir in + dirmap := StrMap.add dir contents !dirmap; + StrSet.mem bf contents + end + else + false + +let file_exists_respecting_case path f = + (* This function ensures that a file with expected lowercase/uppercase + is the correct one, even on case-insensitive file systems *) + let rec aux f = + let bf = Filename.basename f in + let df = Filename.dirname f in + (String.equal df "." || aux df) + && exists_in_dir_respecting_case (Filename.concat path df) bf + in Sys.file_exists (Filename.concat path f) && aux f + let rec search paths test = match paths with | [] -> [] @@ -77,7 +110,7 @@ let where_in_path ?(warn=true) path filename = in check_and_warn (search path (fun lpe -> let f = Filename.concat lpe filename in - if Sys.file_exists f then [lpe,f] else [])) + if file_exists_respecting_case lpe filename then [lpe,f] else [])) let where_in_path_rex path rex = search path (fun lpe -> @@ -93,6 +126,8 @@ let where_in_path_rex path rex = let find_file_in_path ?(warn=true) paths filename = if not (Filename.is_implicit filename) then + (* the name is considered to be a physical name and we use the file + system rules (e.g. possible case-insensitivity) to find it *) if Sys.file_exists filename then let root = Filename.dirname filename in root, filename @@ -100,6 +135,9 @@ let find_file_in_path ?(warn=true) paths filename = errorlabstrm "System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else + (* the name is considered to be the transcription as a relative + physical name of a logical name, so we deal with it as a name + to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> errorlabstrm "System.find_file_in_path" @@ -224,7 +262,7 @@ type time = float * float * float let get_time () = let t = Unix.times () in - (Unix.gettimeofday(), t.tms_utime, t.tms_stime) + (Unix.gettimeofday(), t.Unix.tms_utime, t.Unix.tms_stime) (* Keep only 3 significant digits *) let round f = (floor (f *. 1e3)) *. 1e-3 diff --git a/lib/system.mli b/lib/system.mli index 247d528b..062c8ea8 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool val find_file_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string +val file_exists_respecting_case : string -> string -> bool + (** {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] diff --git a/lib/terminal.ml b/lib/terminal.ml index 58851ed2..de21f102 100644 --- a/lib/terminal.ml +++ b/lib/terminal.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(*