Commit 7d643c00 authored by Pietro Abate's avatar Pietro Abate

[r2005-04-19 16:01:39 by afrisch] Empty log message

Original author: afrisch
Date: 2005-04-19 16:01:39+00:00
parent a0c8cb05
......@@ -24,7 +24,7 @@ let print_to_string f x =
let to_string e =
print_to_string print e
exception Path of t
exception Failed of t
let expected d fail =
let ts = types_of_codes d in
......@@ -33,7 +33,7 @@ let expected d fail =
!a
let make_result pt fail (code,_,_) =
if fail == code then raise (Path pt);
if fail == code then raise (Failed pt);
code
let rec run_disp_basic pt fail f = function
......@@ -152,16 +152,22 @@ let rec simplify = function
with Not_found -> [ x ])
| [] -> assert false
let explain t0 t v =
let check t0 t =
let p = Patterns.make IdSet.empty in
Patterns.define p (Patterns.constr t);
let (d,rhs) = make_branches t0 [ (p,()) ] in
(* The instrumented dispatcher is slower, so we first try the normal
one. This is optimized for the case where the value matches. *)
fun v ->
let (code,_) = Run_dispatch.run_dispatcher d v in
(* let fail = find_array (function Fail -> true | _ -> false) rhs in *)
match rhs.(code) with
| Fail ->
(try ignore (run_disp [] code d v); assert false
with Path p -> Some p)
| _ -> None
| Fail -> ignore (run_disp [] code d v); assert false
| _ -> ()
let explain t0 t =
let f = check t0 t in
fun v ->
try f v; None
with Failed p -> Some p
type t = (Value.t * Types.t Lazy.t) list
exception Failed of t
val print: Format.formatter -> t -> unit
val to_string: t -> string
......@@ -10,3 +12,9 @@ val explain: Types.t -> Types.t -> Value.t -> t option
or [None] if [v] has type [t].
[v] is assumed to have type [t0].
*)
val check: Types.t -> Types.t -> Value.t -> unit
(** Same, but raise [Failed].
A partial appliaction to the first two argument will precompute
the internal automaton. *)
......@@ -37,6 +37,7 @@ module PM = Mk(Custom.Pair(Types)(Custom.List(Patterns.Node)))
module CONST = Mk(Types.Const)
module LAB = Mk(Ident.LabelPool)
module T = Mk(Types)
module T2 = Mk(Custom.Pair(Types)(Types))
module LABA = Mk(Custom.Array(Ident.LabelPool))
module TAG = Mk(Atoms.V)
module TAGA = Mk(Custom.Array(Custom.Pair(Atoms.V)(Custom.Int)))
......@@ -50,6 +51,7 @@ module P = struct
laba : LABA.pchunk;
tag : TAG.pchunk;
taga : TAGA.pchunk;
typ2 : T2.pchunk;
}
let init () =
......@@ -60,6 +62,7 @@ module P = struct
laba = LABA.init ();
tag = TAG.init ();
taga = TAGA.init ();
typ2 = T2.init ();
}
let serialize s c =
......@@ -70,6 +73,7 @@ module P = struct
LABA.serialize s c.laba;
TAG.serialize s c.tag;
TAGA.serialize s c.taga;
T2.serialize s c.typ2;
()
let pm c = PM.put c.pm
......@@ -79,6 +83,7 @@ module P = struct
let label_array c = LABA.put c.laba
let tag c = TAG.put c.tag
let tag_array c = TAGA.put c.taga
let typ2 c t1 t2 = T2.put c.typ2 (t1,t2)
let mk c =
let s = Serialize.Put.run serialize c in
......@@ -98,6 +103,7 @@ module G = struct
laba : Ident.label array LABA.chunk;
tag : Value.t TAG.chunk;
taga : int Atoms.map TAGA.chunk;
typ2 : (Value.t -> unit) T2.chunk;
}
let deserialize s =
......@@ -108,8 +114,9 @@ module G = struct
let laba = LABA.deserialize s in
let tag = TAG.deserialize s in
let taga = TAGA.deserialize s in
let typ2 = T2.deserialize s in
{ pm = pm; cst = cst; lab = lab; typ = typ; laba = laba; tag = tag;
taga = taga }
taga = taga; typ2 = typ2 }
let mk s =
Types.clear_deserialize_table ();
......@@ -143,12 +150,9 @@ module G = struct
let typ chunk i =
T.get (fun x -> x) chunk.typ i
let check chunk t0 t v =
let t0 = typ chunk t0 and t = typ chunk t in
match Explain.explain t0 t v with
| None -> v
| Some p -> failwith (Explain.to_string p)
let check chunk i v =
T2.get (fun (t0,t) -> Explain.check t0 t) chunk.typ2 i v;
v
let record chunk i vs =
Value.mk_record (LABA.get (fun x -> x) chunk.laba i) vs
......
......@@ -10,6 +10,7 @@ module P : sig
val label_array: chunk -> Ident.label array -> int
val tag: chunk -> Atoms.V.t -> int
val tag_array: chunk -> (Atoms.V.t * int) array -> int
val typ2: chunk -> Types.t -> Types.t -> int
end
module G : sig
......@@ -21,7 +22,7 @@ module G : sig
val remove_label: chunk -> int -> Value.t -> Value.t
val get_field: chunk -> int -> Value.t -> Value.t
val typ: chunk -> int -> Types.t
val check: chunk -> int -> int -> Value.t -> Value.t
val check: chunk -> int -> Value.t -> Value.t
val record: chunk -> int -> Value.t array -> Value.t
val constr: chunk -> int -> Value.t array -> Value.t
val constr_const: chunk -> int -> Value.t
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment