From 508d5a99101097948b6de342295eec0d5c8cbe72 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Mar 2016 18:59:51 +0100 Subject: Fixing bug #4105: poor escaping in the protocol between CoqIDE and coqtop. Printing invalid UTF-8 string startled GTK too much, leading to CoqIDE dying improperly. We now check that all strings outputed by Coq are proper UTF-8. This is not perfect, as CoqIDE will sometimes truncate strings which contains the null character, but at least it should not crash. --- lib/unicode.ml | 7 +++++++ lib/unicode.mli | 3 +++ 2 files changed, 10 insertions(+) (limited to 'lib') diff --git a/lib/unicode.ml b/lib/unicode.ml index 1765e93dcd..cfaa73cc11 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -168,6 +168,13 @@ let next_utf8 s i = (c land 0x3F) lsl 6 + (d land 0x3F) else err () +let is_utf8 s = + let rec check i = + let (off, _) = next_utf8 s i in + check (i + off) + in + try check 0 with End_of_input -> true | Invalid_argument _ -> false + (* Check the well-formedness of an identifier *) let initial_refutation j n s = diff --git a/lib/unicode.mli b/lib/unicode.mli index 520203d435..65e75a20d6 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -26,3 +26,6 @@ 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 + +(** Validate an UTF-8 string *) +val is_utf8 : string -> bool -- cgit v1.2.3 From b98e4857a13a4014c65882af5321ebdb09f41890 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 4 Mar 2016 17:40:10 +0100 Subject: Rename Ephemeron -> CEphemeron. Fixes compilation of Coq with OCaml 4.03 beta 1. --- lib/cEphemeron.ml | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/cEphemeron.mli | 52 +++++++++++++++++++++++++++++++ lib/ephemeron.ml | 89 ------------------------------------------------------ lib/ephemeron.mli | 52 ------------------------------- lib/future.ml | 8 ++--- lib/lib.mllib | 2 +- 6 files changed, 146 insertions(+), 146 deletions(-) create mode 100644 lib/cEphemeron.ml create mode 100644 lib/cEphemeron.mli delete mode 100644 lib/ephemeron.ml delete mode 100644 lib/ephemeron.mli (limited to 'lib') diff --git a/lib/cEphemeron.ml b/lib/cEphemeron.ml new file mode 100644 index 0000000000..a38ea11e10 --- /dev/null +++ b/lib/cEphemeron.ml @@ -0,0 +1,89 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* boxed_key = + (* TODO: take a random value here. Is there a random function in OCaml? *) + let bid = ref 0 in + (* According to OCaml Gc module documentation, Pervasives.ref is one of the + few ways of getting a boxed value the compiler will never alias. *) + fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid) + +(* A phantom type to preserve type safety *) +type 'a key = boxed_key + +(* Comparing keys with == grants that if a key is unmarshalled (in the same + process where it was created or in another one) it is not mistaken for + an already existing one (unmarshal has no right to alias). If the initial + value of bid is taken at random, then one also avoids potential collisions *) +module HT = Hashtbl.Make(struct + type t = key_type ref + let equal k1 k2 = k1 == k2 + let hash id = !id +end) + +(* A key is the (unique) value inside a boxed key, hence it does not + keep its corresponding boxed key reachable (replacing key_type by boxed_key + would make the key always reachable) *) +let values : Obj.t HT.t = HT.create 1001 + +(* To avoid a race contidion between the finalization function and + get/create on the values hashtable, the finalization function just + enqueues in an imperative list the item to be collected. Being the list + imperative, even if the Gc enqueue an item while run_collection is operating, + the tail of the list is eventually set to Empty on completion. + Kudos to the authors of Why3 that came up with this solution for their + implementation of weak hash tables! *) +type imperative_list = cell ref +and cell = Empty | Item of key_type ref * imperative_list + +let collection_queue : imperative_list ref = ref (ref Empty) + +let enqueue x = collection_queue := ref (Item (!x, !collection_queue)) + +let run_collection () = + let rec aux l = match !l with + | Empty -> () + | Item (k, tl) -> HT.remove values k; aux tl in + let l = !collection_queue in + aux l; + l := Empty + +(* The only reference to the boxed key is the one returned, when the user drops + it the value eventually disappears from the values table above *) +let create (v : 'a) : 'a key = + run_collection (); + let k = mk_key () in + HT.add values !k (Obj.repr v); + Gc.finalise enqueue k; + k + +(* Avoid raising Not_found *) +exception InvalidKey +let get (k : 'a key) : 'a = + run_collection (); + try Obj.obj (HT.find values !k) + with Not_found -> raise InvalidKey + +(* Simple utils *) +let default k v = + try get k + with InvalidKey -> v + +let iter_opt k f = + match + try Some (get k) + with InvalidKey -> None + with + | None -> () + | Some v -> f v + +let clear () = run_collection () diff --git a/lib/cEphemeron.mli b/lib/cEphemeron.mli new file mode 100644 index 0000000000..1200e4e208 --- /dev/null +++ b/lib/cEphemeron.mli @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a key + +(* May raise InvalidKey *) +exception InvalidKey +val get : 'a key -> 'a + +(* These never fail. *) +val iter_opt : 'a key -> ('a -> unit) -> unit +val default : 'a key -> 'a -> 'a + +val clear : unit -> unit diff --git a/lib/ephemeron.ml b/lib/ephemeron.ml deleted file mode 100644 index a38ea11e10..0000000000 --- a/lib/ephemeron.ml +++ /dev/null @@ -1,89 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* boxed_key = - (* TODO: take a random value here. Is there a random function in OCaml? *) - let bid = ref 0 in - (* According to OCaml Gc module documentation, Pervasives.ref is one of the - few ways of getting a boxed value the compiler will never alias. *) - fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid) - -(* A phantom type to preserve type safety *) -type 'a key = boxed_key - -(* Comparing keys with == grants that if a key is unmarshalled (in the same - process where it was created or in another one) it is not mistaken for - an already existing one (unmarshal has no right to alias). If the initial - value of bid is taken at random, then one also avoids potential collisions *) -module HT = Hashtbl.Make(struct - type t = key_type ref - let equal k1 k2 = k1 == k2 - let hash id = !id -end) - -(* A key is the (unique) value inside a boxed key, hence it does not - keep its corresponding boxed key reachable (replacing key_type by boxed_key - would make the key always reachable) *) -let values : Obj.t HT.t = HT.create 1001 - -(* To avoid a race contidion between the finalization function and - get/create on the values hashtable, the finalization function just - enqueues in an imperative list the item to be collected. Being the list - imperative, even if the Gc enqueue an item while run_collection is operating, - the tail of the list is eventually set to Empty on completion. - Kudos to the authors of Why3 that came up with this solution for their - implementation of weak hash tables! *) -type imperative_list = cell ref -and cell = Empty | Item of key_type ref * imperative_list - -let collection_queue : imperative_list ref = ref (ref Empty) - -let enqueue x = collection_queue := ref (Item (!x, !collection_queue)) - -let run_collection () = - let rec aux l = match !l with - | Empty -> () - | Item (k, tl) -> HT.remove values k; aux tl in - let l = !collection_queue in - aux l; - l := Empty - -(* The only reference to the boxed key is the one returned, when the user drops - it the value eventually disappears from the values table above *) -let create (v : 'a) : 'a key = - run_collection (); - let k = mk_key () in - HT.add values !k (Obj.repr v); - Gc.finalise enqueue k; - k - -(* Avoid raising Not_found *) -exception InvalidKey -let get (k : 'a key) : 'a = - run_collection (); - try Obj.obj (HT.find values !k) - with Not_found -> raise InvalidKey - -(* Simple utils *) -let default k v = - try get k - with InvalidKey -> v - -let iter_opt k f = - match - try Some (get k) - with InvalidKey -> None - with - | None -> () - | Some v -> f v - -let clear () = run_collection () diff --git a/lib/ephemeron.mli b/lib/ephemeron.mli deleted file mode 100644 index 1200e4e208..0000000000 --- a/lib/ephemeron.mli +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a key - -(* May raise InvalidKey *) -exception InvalidKey -val get : 'a key -> 'a - -(* These never fail. *) -val iter_opt : 'a key -> ('a -> unit) -> unit -val default : 'a key -> 'a -> 'a - -val clear : unit -> unit diff --git a/lib/future.ml b/lib/future.ml index 5cd2beba91..e8f33db5e1 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -62,7 +62,7 @@ and 'a comp = | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *) and 'a comput = - | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) Ephemeron.key + | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) CEphemeron.key | Finished of 'a and 'a computation = 'a comput ref @@ -70,13 +70,13 @@ and 'a computation = 'a comput ref let unnamed = "unnamed" let create ?(name=unnamed) ?(uuid=UUID.fresh ()) f x = - ref (Ongoing (name, Ephemeron.create (uuid, f, Pervasives.ref x))) + ref (Ongoing (name, CEphemeron.create (uuid, f, Pervasives.ref x))) let get x = match !x with | Finished v -> unnamed, UUID.invalid, id, ref (Val (v,None)) | Ongoing (name, x) -> - try let uuid, fix, c = Ephemeron.get x in name, uuid, fix, c - with Ephemeron.InvalidKey -> + try let uuid, fix, c = CEphemeron.get x in name, uuid, fix, c + with CEphemeron.InvalidKey -> name, UUID.invalid, id, ref (Exn (NotHere name, Exninfo.null)) type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ] diff --git a/lib/lib.mllib b/lib/lib.mllib index f3f6ad8fc7..6805ce4919 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -15,6 +15,6 @@ Rtree Heap Unionfind Genarg -Ephemeron +CEphemeron Future RemoteCounter -- cgit v1.2.3