Skip to content

C
cduce
Commit 6ee6ef2e authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files
Options

Improve pretty printing of Bdds and add debug directive to interactively... 

Improve pretty printing of Bdds and add debug directive to interactively inspect the internal representation of types.
parent edd4e79d
Hide whitespace changes
Inline Side-by-side
Showing with 234 additions and 147 deletions
driver/cduce.ml
View file @ 6ee6ef2e
......@@ -9,11 +9,11 @@ exception InvalidObjectFilename of string
let extra_specs = ref []
(* if set to false toplevel exception aren't cought.
(* if set to false toplevel exception aren't cought.
* Useful for debugging with OCAMLRUNPARAM="b" *)
let catch_exceptions = true
(* retuns a filename without the suffix suff if any *)
(* retuns a filename without the suffix suff if any *)
let prefix filename suff =
if Filename.check_suffix filename suff then
try
......@@ -39,7 +39,7 @@ let rec is_abstraction = function
| Ast.LocatedExpr (_,e) -> is_abstraction e
| _ -> false
let print_norm ppf d =
let print_norm ppf d =
Types.Print.pp_type ppf ((*Types.normalize*) d)
let print_sample ppf s =
......@@ -74,7 +74,7 @@ let directive_help ppf =
#reinit_ns;; reinitialize namespace processing
#help;; shows this help message
#print_type <type>;; dump internal representation of <type>
#debug ;;
#debug ;;
#silent;; turn off outputs from the toplevel
#verbose;; turn on outputs from the toplevel
#builtins;; shows embedded OCaml values
......@@ -83,7 +83,8 @@ let directive_help ppf =
let directive_help_debug ppf =
Format.fprintf ppf
"Debug sub-directives:
#debug sybtype <type> <type> ;; check if t1 < t2 for all substitutions
#debug subtype <type> <type> ;; check if t1 < t2 for all substitutions
#debug bdd <type>;; dump the internal type representation
#debug typed <expr> ;; dump typed internal representation
#debug lambda <expr> ;; dump lambda internal representation
#debug accept <???> ;;
......@@ -95,33 +96,33 @@ let directive_help_debug ppf =
let rec print_exn ppf = function
| Location (loc, w, exn) ->
Cduce_loc.print_loc ppf (loc,w);
Cduce_loc.html_hilight (loc,w);
Cduce_loc.html_hilight (loc,w);
print_exn ppf exn
| Value.CDuceExn v ->
Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
print_value v
| Typer.WrongLabel (t,l) ->
Format.fprintf ppf "Wrong record selection; field %a "
Format.fprintf ppf "Wrong record selection; field %a "
Label.print_attr l;
Format.fprintf ppf "not present in an expression of type:@.%a@."
print_norm t
| Typer.ShouldHave (t,msg) ->
Format.fprintf ppf "This expression should have type:@.%a@.%a@."
Format.fprintf ppf "This expression should have type:@.%a@.%a@."
print_norm t
print_protect msg
| Typer.ShouldHave2 (t1,msg,t2) ->
Format.fprintf ppf "This expression should have type:@.%a@.%a %a@."
Format.fprintf ppf "This expression should have type:@.%a@.%a %a@."
print_norm t1
print_protect msg
print_norm t2
| Typer.Error s ->
Format.fprintf ppf "%a@." print_protect s
| Typer.Constraint (s,t) ->
Format.fprintf ppf "This expression should have type:@.%a@."
Format.fprintf ppf "This expression should have type:@.%a@."
print_norm t;
Format.fprintf ppf "but its inferred type is:@.%a@."
Format.fprintf ppf "but its inferred type is:@.%a@."
print_norm s;
Format.fprintf ppf "which is not a subtype, as shown by the sample:@.%a@."
Format.fprintf ppf "which is not a subtype, as shown by the sample:@.%a@."
print_sample (Sample.get (Types.diff s t))
| Typer.NonExhaustive t ->
Format.fprintf ppf "This pattern matching is not exhaustive@.";
......@@ -132,7 +133,7 @@ let rec print_exn ppf = function
Format.fprintf ppf "Unbound identifier %a%s@." Ident.print x
(if tn then " (it is a type name)" else "")
| Typer.UnboundExtId (cu,x) ->
Format.fprintf ppf "Unbound external identifier %a:%a@."
Format.fprintf ppf "Unbound external identifier %a:%a@."
U.print (Librarian.name cu)
Ident.print x
| Ulexer.Error (i,j,s) ->
......@@ -140,7 +141,7 @@ let rec print_exn ppf = function
Cduce_loc.print_loc ppf loc;
Cduce_loc.html_hilight loc;
Format.fprintf ppf "%s" s
| Parser.Error s | Stream.Error s ->
| Parser.Error s | Stream.Error s ->
Format.fprintf ppf "Parsing error: %a@." print_protect s
| Librarian.InconsistentCrc name ->
Format.fprintf ppf "Link error:@.";
......@@ -163,14 +164,14 @@ let rec print_exn ppf = function
| Cduce_loc.Generic s ->
Format.fprintf ppf "%a@." print_protect s
| Ns.Label.Not_unique ((ns1,s1),(ns2,s2)) ->
Format.fprintf ppf "Collision on label hash: {%a}:%a, {%a}:%a"
U.print (Ns.Uri.value ns1)
U.print s1
U.print (Ns.Uri.value ns2)
Format.fprintf ppf "Collision on label hash: {%a}:%a, {%a}:%a"
U.print (Ns.Uri.value ns1)
U.print s1
U.print (Ns.Uri.value ns2)
U.print s2
| Ns.Uri.Not_unique (ns1,ns2) ->
Format.fprintf ppf "Collision on namespaces hash: %a, %a"
U.print ns1
Format.fprintf ppf "Collision on namespaces hash: %a, %a"
U.print ns1
U.print ns2
| Sequence.Error (Sequence.CopyTag (t,expect)) ->
Format.fprintf ppf "Tags in %a will be copied, but only %a are allowed.@.Counter-example:%a@."
......@@ -185,12 +186,12 @@ let rec print_exn ppf = function
| Sequence.Error (Sequence.UnderTag (t,exn)) ->
Format.fprintf ppf "Under tag %a:@." Types.Print.pp_type t;
print_exn ppf exn
| exn ->
(* raise exn *)
Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
let eval_quiet tenv cenv e =
let eval_quiet tenv cenv e =
let (e,_) = Typer.type_expr tenv e in
Compile.compile_eval_expr cenv e
......@@ -201,6 +202,13 @@ let debug ppf tenv cenv = function
and t2 = Types.descr (Typer.typ tenv t2) in
let s = Types.subtype t1 t2 in
Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
| `Bdd (t) ->
Format.fprintf ppf "[DEBUG:bdd]@.";
let t = Types.descr (Typer.typ tenv t) in
Format.fprintf ppf "@[%a@]@." Types.Print.dump t
| `Id_bdd (i) ->
Format.fprintf ppf "[DEBUG:id_bdd]@.";
Format.fprintf ppf "@[%a@]@." Types.Print.dump_by_id i
| `Sample t ->
Format.fprintf ppf "[DEBUG:sample]@.";
(try
......@@ -209,7 +217,7 @@ let debug ppf tenv cenv = function
Format.fprintf ppf "witness: %a@." Types.Witness.pp (Types.witness t);
with Not_found ->
Format.fprintf ppf "Empty type : no sample !@.")
| `Filter (t,p) ->
| `Filter (t,p) ->
let t = Typer.typ tenv t
and p = Typer.pat tenv p in
Format.fprintf ppf "[DEBUG:filter t=%a p=%a]@."
......@@ -217,7 +225,7 @@ let debug ppf tenv cenv = function
Patterns.Print.pp (Patterns.descr p);
let f = Patterns.filter (Types.descr t) p in
IdMap.iteri (fun x t ->
Format.fprintf ppf " %a:%a@."
Format.fprintf ppf " %a:%a@."
Ident.print x
print_norm (Types.descr t)) f
| `Accept p ->
......@@ -228,7 +236,7 @@ let debug ppf tenv cenv = function
| `Compile (t,pl) ->
Format.fprintf ppf "[DEBUG:compile]@.";
let no = ref (-1) in
let t = Types.descr (Typer.typ tenv t)
let t = Types.descr (Typer.typ tenv t)
and pl = List.map (fun p -> incr no; (Typer.pat tenv p, !no)) pl in
let (state,rhs) = Patterns.Compile.make_branches t pl in
......@@ -242,11 +250,11 @@ let debug ppf tenv cenv = function
| `Single t ->
Format.fprintf ppf "[DEBUG:single]@.";
let t = Typer.typ tenv t in
(try
(try
let c = Sample.single (Types.descr t) in
Format.fprintf ppf "Constant:%a@." Types.Print.pp_const c
with
| Exit -> Format.fprintf ppf "Non constant@."
| Exit -> Format.fprintf ppf "Non constant@."
| Not_found -> Format.fprintf ppf "Empty@.")
| `Typed e ->
Format.fprintf ppf "[DEBUG:typed]@.";
......@@ -299,17 +307,17 @@ let print_value_opt ppf = function
let show ppf id t v =
if !silent then ()
else Format.fprintf ppf "@[%a : @[%a%a@]@]@."
print_id_opt id
print_norm t
print_id_opt id
print_norm t
print_value_opt v
let ev_top ~run ~show ?directive phs =
let (tenv,cenv,_) =
let (tenv,cenv,_) =
Compile.comp_unit ~run ~show ?directive
!typing_env !compile_env phs in
typing_env := tenv;
compile_env := cenv
let phrases ppf phs =
ev_top ~run:true ~show:(show ppf) ~directive:(directive ppf) phs
......@@ -317,10 +325,10 @@ let phrases ppf phs =
let catch_exn ppf_err exn =
if not catch_exceptions then raise exn;
match exn with
| (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break)
as e ->
| (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break)
as e ->
raise e
| exn ->
| exn ->
print_exn ppf_err exn;
Format.fprintf ppf_err "@."
......@@ -341,7 +349,7 @@ let compile src out_dir =
if not (Filename.check_suffix src ".cd")
then raise (InvalidInputFilename src);
let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
let out_dir =
let out_dir =
match out_dir with
| None -> Filename.dirname src
| Some x -> x in
......@@ -350,10 +358,10 @@ let compile src out_dir =
Librarian.compile_save !verbose name src out;
exit 0
with exn -> catch_exn Format.err_formatter exn; exit 1
let compile_run src =
try
let name =
let name =
if src = "" then "<stdin>"
else
if not (Filename.check_suffix src ".cd")
......@@ -363,7 +371,7 @@ let compile_run src =
Librarian.compile_run !verbose name src;
with exn -> catch_exn Format.err_formatter exn; exit 1
let run obj =
let run obj =
Cduce_loc.obj_path := (Filename.dirname obj)::!Cduce_loc.obj_path ;
let obj = Filename.basename obj in
try
......@@ -381,7 +389,7 @@ let eval s =
let vals = ref [] in
let show id t v =
match id,v with
| Some id, Some v ->
| Some id, Some v ->
vals := (Some (Atoms.V.mk id),v) :: !vals
| None, Some v ->
vals := (None,v) :: !vals
......@@ -389,18 +397,18 @@ let eval s =
in
ev_top ~run:true ~show phs;
List.rev !vals
let eval s =
try eval s
with exn ->
with exn ->
let b = Buffer.create 1024 in
let ppf = Format.formatter_of_buffer b in
print_exn ppf exn;
Format.fprintf ppf "@.";
Value.failwith' (Buffer.contents b)
let () =
let () =
Operators.register_fun "eval_expr" Builtin_defs.string_latin1 Types.any
(fun v ->
match eval (Value.cduce2ocaml_string v) with
......
misc/bool.ml
View file @ 6ee6ef2e
......@@ -19,7 +19,7 @@ sig
val iter: (elem-> unit) -> t -> unit
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:(elem -> 'b) -> t -> 'b
......@@ -55,13 +55,13 @@ struct
the minimum of the two when egality ... *)
let rec compare a b =
if (a == b) then 0
if (a == b) then 0
else match (a,b) with
| Split (h1,x1, p1,i1,n1), Split (h2,x2, p2,i2,n2) ->
if h1 < h2 then -1 else if h1 > h2 then 1
if h1 < h2 then -1 else if h1 > h2 then 1
else let c = X.compare x1 x2 in if c <> 0 then c
else let c = compare p1 p2 in if c <> 0 then c
else let c = compare i1 i2 in if c <> 0 then c
else let c = compare i1 i2 in if c <> 0 then c
else compare n1 n2
| True,_ -> -1
| _, True -> 1
......@@ -74,7 +74,7 @@ struct
| False -> 0
| Split(h, _,_,_,_) -> h
let compute_hash x p i n =
let compute_hash x p i n =
(X.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
let rec check = function
......@@ -89,7 +89,7 @@ struct
let atom x =
let h = X.hash x + 17 in (* partial evaluation of compute_hash... *)
Split (h, x,True,False,False)
let neg_atom x =
let h = X.hash x + 16637 in (* partial evaluation of compute_hash... *)
Split (h, x,False,False,True)
......@@ -99,11 +99,11 @@ struct
| _ -> ()
let rec dump ppf = function
| True -> Format.fprintf ppf "+"
| False -> Format.fprintf ppf "-"
| Split (_,x, p,i,n) ->
Format.fprintf ppf "%i(@[%a,%a,%a@])"
(* X.dump x *) (X.hash x) dump p dump i dump n
| True -> Format.fprintf ppf "⊤"
| False -> Format.fprintf ppf "⊥"
| Split (_,x, p,i,n) ->
Format.fprintf ppf "@[@[%a@][@[<hov>%a,@\n%a,@\n%a@]]@]"
X.dump x dump p dump i dump n
let rec print f ppf = function
| True -> Format.fprintf ppf "Any"
......@@ -111,25 +111,25 @@ struct
| Split (_, x, p,i, n) ->
let flag = ref false in
let b () = if !flag then Format.fprintf ppf " | " else flag := true in
(match p with
(match p with
| True -> b(); Format.fprintf ppf "%a" f x
| False -> ()
| _ -> b (); Format.fprintf ppf "%a & @[(%a)@]" f x (print f) p );
(match i with
(match i with
| True -> assert false;
| False -> ()
| _ -> b(); print f ppf i);
(match n with
(match n with
| True -> b (); Format.fprintf ppf "@[~%a@]" f x
| False -> ()
| _ -> b (); Format.fprintf ppf "@[~%a@] & @[(%a)@]" f x (print f) n)
let print a f = function
| True -> [ fun ppf -> Format.fprintf ppf "%s" a ]
| False -> []
| c -> [ fun ppf -> print f ppf c ]
let rec get accu pos neg = function
| True -> (pos,neg) :: accu
| False -> accu
......@@ -139,7 +139,7 @@ struct
let accu = get accu pos (x::neg) n in
let accu = get accu pos neg i in
accu
let get x = get [] [] [] x
let rec get' accu pos neg = function
......@@ -171,7 +171,7 @@ struct
cup (cup p i) n
in
aux b
(* Invariant: correct hash value *)
let split0 x pos ign neg =
......@@ -194,7 +194,7 @@ struct
| b :: l -> (equal a b) || (has_same a l)
let rec split x p i n =
if i == True then True
if i == True then True
else if equal p n then p ++ i
else let p = simplify p [i] and n = simplify n [i] in
if equal p n then p ++ i
......@@ -208,17 +208,17 @@ struct
if (has_true l) || (has_same a l) then False
else s_aux2 a x p i n [] [] [] l
and s_aux2 a x p i n ap ai an = function
| [] ->
let p = simplify p ap
| [] ->
let p = simplify p ap
and n = simplify n an
and i = simplify i ai in
if equal p n then p ++ i else split0 x p i n
| b :: l -> s_aux3 a x p i n ap ai an l b
| b :: l -> s_aux3 a x p i n ap ai an l b
and s_aux3 a x p i n ap ai an l = function
| False -> s_aux2 a x p i n ap ai an l
| True -> assert false
| Split (_,x2,p2,i2,n2) as b ->
if equal a b then False
if equal a b then False
else let c = X.compare x2 x in
if c < 0 then s_aux3 a x p i n ap ai an l i2
else if c > 0 then s_aux2 a x p i n (b :: ap) (b :: ai) (b :: an) l
......@@ -243,16 +243,16 @@ struct
| Split (_,x1, p1,i1,n1), Split (_,x2, p2,i2,n2) ->
let c = X.compare x1 x2 in
if c = 0 then
split x1
split x1
(p1 ** (p2 ++ i2) ++ (p2 ** i1))
(i1 ** i2)
(n1 ** (n2 ++ i2) ++ (n2 ** i1))
(* if (p2 == True) && (n2 == False)
(n1 ** (n2 ++ i2) ++ (n2 ** i1))
(* if (p2 == True) && (n2 == False)
then split x1 (p1 ++ i1) (i1 ** i2) (n1 ** i2)
else if (p2 == False) && (n2 == True)
then split x1 (p1 ** i2) (i1 ** i2) (n1 ++ i1)
else
split x1 ((p1++i1) ** (p2 ++ i2)) False ((n1 ++ i1) ** (n2 ++ i2))
else
split x1 ((p1++i1) ** (p2 ++ i2)) False ((n1 ++ i1) ** (n2 ++ i2))
*)
else if c < 0 then split x1 (p1 ** b) (i1 ** b) (n1 ** b)
else split x2 (p2 ** a) (i2 ** a) (n2 ** a)
......@@ -281,16 +281,16 @@ struct
| True -> False
| False -> True
| Split (_,x, p,i,False) -> split x False (neg (i ++ p)) (neg i)
| Split (_,x, False,i,n) -> split x (neg i) (neg (i ++ n)) False
| Split (_,x, p,False,n) -> split x (neg p) (neg (p ++ n)) (neg n)
(* | Split (_,x, p, False, False) ->
| Split (_,x, False,i,n) -> split x (neg i) (neg (i ++ n)) False
| Split (_,x, p,False,n) -> split x (neg p) (neg (p ++ n)) (neg n)
(* | Split (_,x, p, False, False) ->
split x False (neg p) True
| Split (_,x, False, False, n) -> split x True (neg n) False *)
| Split (_,x, p,i,n) -> split x (neg (i ++ p)) False (neg (i ++ n))
let rec ( // ) a b =
let rec ( // ) a b =
(* if equal a b then False *)
if a == b then False
if a == b then False
else match (a,b) with
| False,_ | _, True -> False
| a, False -> a
......@@ -298,18 +298,18 @@ struct
| Split (_,x1, p1,i1,n1), Split (_,x2, p2,i2,n2) ->
let c = X.compare x1 x2 in
if c = 0 then
if (i2 == False) && (n2 == False)
if (i2 == False) && (n2 == False)
then split x1 (p1 // p2) (i1 // p2) (n1 ++ i1)
(* else if (i2 == False) && (p2 == False)
then split x1 (p1 ++ i1) (i1 // n2) (n1 // n2) *)
else
else
split x1 ((p1++i1) // (p2 ++ i2)) False ((n1++i1) // (n2 ++ i2))
else if c < 0 then
split x1 (p1 // b) (i1 // b) (n1 // b)
split x1 (p1 // b) (i1 // b) (n1 // b)
(* split x1 ((p1 ++ i1)// b) False ((n1 ++i1) // b) *)
else
split x2 (a // (i2 ++ p2)) False (a // (i2 ++ n2))
let cup = ( ++ )
let cap = ( ** )
......@@ -323,13 +323,13 @@ struct
| Split (_,y,p,i,n) ->
let c = X.compare x y in
assert (c <> 0);
if (c < 0) then
if (c < 0) then
if pos then split x a False False
else split x False False a
else split y (cap_atom x pos p) (cap_atom x pos i) (cap_atom x pos n)
*)
(*
let not_triv = function
| True | False -> false
......@@ -339,21 +339,21 @@ struct
let d = diff x y in
if (not_triv x) && (not_triv y) then
Format.fprintf Format.std_formatter "X = %a@\nY = %a@\nX\\Z = %a@\n"
dump x dump y dump d;
dump x dump y dump d;
d
let cap x y =
let d = cap x y in
if (not_triv x) && (not_triv y) then
Format.fprintf Format.std_formatter "X = %a@\nY = %a@\nX**Z = %a@\n"
dump x dump y dump d;
dump x dump y dump d;
d
let cup x y =
let d = cup x y in
if (not_triv x) && (not_triv y) then
Format.fprintf Format.std_formatter "X = %a@\nY = %a@\nX++Z = %a@\n"
dump x dump y dump d;
dump x dump y dump d;
d
*)
end
......@@ -388,20 +388,20 @@ struct
module W = Weak(*Myweak*).Make(
struct
type t = node
let hash = function
| Zero | One -> assert false
| Branch (v,yes,no,_,_) ->
| Branch (v,yes,no,_,_) ->
1 + 17*X.hash v + 257*(id yes) + 65537*(id no)
let equal x y = (x == y) || match x,y with
| Branch (v1,yes1,no1,id1,_), Branch (v2,yes2,no2,id2,_) ->
(id1 == 0 || id2 == 0) && X.equal v1 v2 &&
(id1 == 0 || id2 == 0) && X.equal v1 v2 &&
(yes1 == yes2) && (no1 == no2)
| _ -> assert false
end)
let table = W.create 16383
type branch =
type branch =
{ v : X.t; yes : node; no : node; mutable id : int; neg : branch }
let mk v yes no =
if yes == no then yes
......@@ -409,7 +409,7 @@ struct
let rec pos = Branch (v,yes,no,0,Branch (v,neg yes,neg no,0,pos)) in
let x = W.merge table pos in
let pos : branch = Obj.magic x in
if (pos.id == 0)
if (pos.id == 0)
then (let n = !max_id in
max_id := succ n;
pos.id <- n;
......@@ -431,15 +431,15 @@ struct
| Branch (v1,yes1,no1,id1,neg1), Branch (v2,yes2,no2,id2,neg2) ->
if (x1 == neg2) then One
else
let k,h =
let k,h =
if id1<id2 then (x1,x2),id1+65537*id2 else (x2,x1),id2+65537*id1 in
let h = (h land max_int) mod memo_size in
let i = memo_occ.(h) in
let k' = memo_keys.(h) in
if (k' != dummy) && (eg2 k k')
if (k' != dummy) && (eg2 k k')
then (memo_occ.(h) <- succ i; memo_vals.(h))
else
let r =
else
let r =
let c = X.compare v1 v2 in
if (c = 0) then mk v1 (cup yes1 yes2) (cup no1 no2)
else if (c < 0) then mk v1 (cup yes1 x2) (cup no1 x2)
......@@ -448,12 +448,12 @@ struct
memo_occ.(h) <- 1)
else memo_occ.(h) <- pred i;
r
let rec dump ppf = function
| One -> Format.fprintf ppf "+"
| Zero -> Format.fprintf ppf "-"
| Branch (x,p,n,id,_) ->
Format.fprintf ppf "%i:%a(@[%a,%a@])"
| Branch (x,p,n,id,_) ->
Format.fprintf ppf "%i:%a(@[%a,%a@])"
id
X.dump x dump p dump n
......@@ -461,10 +461,10 @@ struct
let cup x y =
let d = cup x y in
Format.fprintf Format.std_formatter "X = %a@\nY = %a@\nX+Z = %a@\n"
dump x dump y dump d;
dump x dump y dump d;
d
*)
let cap x1 x2 = neg (cup (neg x1) (neg x2))
let diff x1 x2 = neg (cup (neg x1) x2)
......@@ -482,20 +482,20 @@ struct
| Branch (x,p,n,_,_) ->
let flag = ref false in
let b () = if !flag then Format.fprintf ppf " | " else flag := true in
(match p with
(match p with
| One -> b(); Format.fprintf ppf "%a" f x
| Zero -> ()
| _ -> b (); Format.fprintf ppf "%a & @[(%a)@]" f x (print f) p );
(match n with
(match n with
| One -> b (); Format.fprintf ppf "@[~%a@]" f x
| Zero -> ()
| _ -> b (); Format.fprintf ppf "@[~%a@] & @[(%a)@]" f x (print f) n)
let print a f = function
| One -> [ fun ppf -> Format.fprintf ppf "%s" a ]
| Zero -> []
| c -> [ fun ppf -> print f ppf c ]
let rec get accu pos neg = function
| One -> (pos,neg) :: accu
| Zero -> accu
......@@ -504,9 +504,9 @@ struct
let accu = get accu (x::pos) neg p in
let accu = get accu pos (x::neg) n in
accu
let get x = get [] [] [] x
let compute ~empty ~full ~cup ~cap ~diff ~atom b =
let rec aux = function
| One -> full
......@@ -517,12 +517,12 @@ struct
cup p n
in
aux b
let empty = Zero
let full = One
let rec serialize t = function
| (Zero | One) as b ->
| (Zero | One) as b ->
Serialize.Put.bool t true; Serialize.Put.bool t (b == One)
| Branch (x,p,n,_,_) ->
Serialize.Put.bool t false;
......@@ -544,13 +544,13 @@ struct
(* mk x p n is not ok, because order of keys might have changed!
OPT TODO: detect when this is ok *)
let trivially_disjoint x y = neg x == y
let trivially_disjoint x y = neg x == y
let compare x y = compare (id x) (id y)
let equal x y = x == y
let hash x = id x
let check x = ()
type bdd = False | True | Br of elem * t * t
type bdd = False | True | Br of elem * t * t
let br = function
| Zero -> False | One -> True | Branch (x,p,n,_,_) -> Br (x,p,n)
end
......@@ -570,19 +570,19 @@ module Make2(X : Custom.T) = struct
let tset_equal = ref ()
let tset_compare = ref ()
module rec TSet : Hashset.SET with type elt = TSet.t s =
module rec TSet : Hashset.SET with type elt = TSet.t s =
Hashset.MakeSet(
struct
type t = TSet.t s
let compare t1 t2 =
if (t1 == t2) then 0
let compare t1 t2 =
if (t1 == t2) then 0
else let x = t1.hash and y = t2.hash in
if x < y then (-1) else if x > y then 1
else let c = XSet.compare t1.pos t2.pos in if c <> 0 then c
else let c = XSet.compare t1.neg t2.neg in if c <> 0 then c
else (Obj.magic !tset_compare) t1.sub t2.sub
let equal t1 t2 =
let equal t1 t2 =
(t1 == t2) ||
(t1.hash == t2.hash &&
XSet.equal t1.pos t2.pos &&
......@@ -591,23 +591,23 @@ module Make2(X : Custom.T) = struct
let hash t = t.hash
end)
let () =
let () =
tset_compare := Obj.magic TSet.compare;
tset_equal := Obj.magic TSet.equal
type elem = X.t
type t = TSet.t s
let compare t1 t2 =
if (t1 == t2) then 0
let compare t1 t2 =
if (t1 == t2) then 0
else let x = t1.hash and y = t2.hash in
if x < y then (-1) else if x > y then 1
else let c = XSet.compare t1.pos t2.pos in if c <> 0 then c
else let c = XSet.compare t1.neg t2.neg in if c <> 0 then c
else TSet.compare t1.sub t2.sub
let equal t1 t2 =
let equal t1 t2 =
(t1 == t2) ||
(t1.hash == t2.hash &&
XSet.equal t1.pos t2.pos &&
......@@ -635,7 +635,7 @@ module Make2(X : Custom.T) = struct
sub = sub;
(* vars = vars; *)
hash = XSet.hash pos + 17 * XSet.hash neg + 257 * TSet.hash sub }
let any = make XSet.empty XSet.empty TSet.empty
let empty = make XSet.empty XSet.empty (TSet.singleton any)
......@@ -643,7 +643,7 @@ module Make2(X : Custom.T) = struct
let atom x = make (XSet.singleton x) XSet.empty TSet.empty
let compl t =
if t == any then empty else if t == empty then any
if t == any then empty else if t == empty then any
else
match XSet.is_empty t.pos, XSet.is_empty t.neg, TSet.is_empty t.sub with
| true,true,false ->
......@@ -672,13 +672,13 @@ module Make2(X : Custom.T) = struct
let cap t1 t2 =
if (t1 == any) || (equal t1 t2) || (triv_subset t2 t1) then t2
if (t1 == any) || (equal t1 t2) || (triv_subset t2 t1) then t2
else if (t2 == any) || (triv_subset t1 t2) then t1
else if (t1 == empty || t2 == empty)
else if (t1 == empty || t2 == empty)
|| not (XSet.disjoint t1.pos t2.neg)
|| not (XSet.disjoint t1.neg t2.pos)
|| TSet.mem t1 t2.sub
|| TSet.mem t2 t1.sub then empty
|| TSet.mem t2 t1.sub then empty