Commit 1c1ca633 authored by Pietro Abate's avatar Pietro Abate

Propagate data structure changes throught the code

parent f2f4c46b
......@@ -8,7 +8,8 @@ true: -traverse
<compile>: include
<schema>: include
<runtime>: include
<{misc,types,typing,schema,compile,runtime}/*.cmx>: for-pack(Cduce_test)
#<{misc,types,typing,schema,compile,runtime}/*.cmx>: for-pack(Cduce_test)
<{misc,types}/*.cmx>: for-pack(Cduce_test)
<{misc,types}/*.cmx>: for-pack(Cduce_boolvar)
<parser/**>: package(ulex), package(netstring), syntax(camlp4o)
......
......@@ -17,3 +17,4 @@ Normal
Pretty
Stats
BoolVar
Types
......@@ -29,6 +29,7 @@ sig
*)
val trivially_disjoint: t -> t -> bool
end
module type MAKE = functor (X : Custom.T) -> S with type elem = X.t
......@@ -53,7 +54,6 @@ struct
(* Idea: add a mutable "unique" identifier and set it to
the minimum of the two when egality ... *)
let rec compare a b =
if (a == b) then 0
else match (a,b) with
......@@ -77,7 +77,6 @@ struct
let compute_hash x p i n =
(X.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
let rec check = function
| True | False -> ()
| Split (h,x,p,i,n) ->
......@@ -106,7 +105,6 @@ struct
Format.fprintf ppf "%i(@[%a,%a,%a@])"
(* X.dump x *) (X.hash x) dump p dump i dump n
let rec print f ppf = function
| True -> Format.fprintf ppf "Any"
| False -> Format.fprintf ppf "Empty"
......@@ -161,7 +159,6 @@ struct
let get' x = get' [] [] [] x
let compute ~empty ~full ~cup ~cap ~diff ~atom b =
let rec aux = function
| True -> full
......@@ -179,10 +176,6 @@ struct
let split0 x pos ign neg =
Split (compute_hash x pos ign neg, x, pos, ign, neg)
let empty = False
let full = True
......
......@@ -46,7 +46,7 @@ and pexpr =
(* CDuce is a Lambda-calculus ... *)
| Var of U.t
| TVar of U.t
| TVar of Types.Vars.V.t
| Apply of pexpr * pexpr
| Abstraction of abstr
......
......@@ -62,7 +62,7 @@ let tuple_queue =
List.fold_right (fun x q -> Pair (x, q))
let char = mknoloc (Internal (Types.char Chars.any))
let char = mknoloc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm Chars.any))))
let string_regexp = Star (Elem char)
let seq_of_string s =
......@@ -298,7 +298,7 @@ EXTEND Gram
| e1 = expr; "&&"; e2 = expr -> exp _loc (logical_and e1 e2)
| e = expr; op = "/"; p = pat LEVEL "simple" ->
(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
let tag = mk _loc (Internal (Types.atom (Atoms.any))) in
let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.any))))) in
let att = mk _loc (Internal Types.Record.any) in
let any = mk _loc (Internal Types.any) in
let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
......@@ -307,7 +307,7 @@ EXTEND Gram
exp _loc (Transform (e,[p, Var id_dummy]))
| e = expr; "/@"; a = ident_or_keyword ->
(* transform e with <(Atom) {a=$$$}>_ -> [$$$] *)
let tag = mk _loc (Internal (Types.atom Atoms.any)) in
let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.any))))) in
let any = mk _loc (Internal Types.any) in
let att = mk _loc (Record
(true, [(label a,
......@@ -330,7 +330,7 @@ EXTEND Gram
set_ref
(Var stk)
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
let tag = mknoloc (Internal (Types.atom (Atoms.any))) in
let tag = mknoloc (Internal (Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.any))))) in
let att = mknoloc (Internal Types.Record.any) in
let any = mknoloc (Internal Types.any) in
let re = (SeqCapture(noloc,y,Star(Elem(any)))) in
......@@ -403,8 +403,8 @@ EXTEND Gram
tag: [ [ a = ident_or_keyword -> exp _loc (Atom (ident a)) ] ];
tag_type: [
[ "_" -> mk _loc (Internal (Types.atom Atoms.any))
| "$"; a = ident_or_keyword -> mk _loc (Cst (TVar (ident a)))
[ "_" -> mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.any)))))
| "$"; a = ident_or_keyword -> mk _loc (Cst (TVar a))
| a = ident_or_keyword -> mk _loc (Cst (Atom (ident a)))
| t = ANY_IN_NS -> mk _loc (NsT (ident t))
]
......@@ -569,13 +569,13 @@ EXTEND Gram
| i = STRING1; "--"; j = STRING1 ->
let i = Chars.V.mk_int (parse_char _loc i)
and j = Chars.V.mk_int (parse_char _loc j) in
Elem (mk _loc (Internal (Types.char (Chars.char_class i j))))
Elem (mk _loc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class i j))))))
| s = STRING1 ->
List.fold_right
(fun c accu ->
let c = Chars.V.mk_int c in
let c = Chars.atom c in
Seq (Elem (mknoloc (Internal (Types.char c))), accu))
Seq (Elem (mknoloc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm c))))), accu))
(seq_of_string s)
Epsilon ]
| [ e = pat LEVEL "simple" -> Elem e
......@@ -619,20 +619,20 @@ EXTEND Gram
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
mk _loc (Internal (Types.interval (Intervals.bounded i j)))
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.bounded i j)))))
| i = INT ->
let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Intervals.atom i)))
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.atom i)))))
| "*"; "--"; j = INT ->
let j = Intervals.V.mk j in
mk _loc (Internal (Types.interval (Intervals.left j)))
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.left j)))))
| i = INT; "--"; "*" ->
let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Intervals.right i)))
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.right i)))))
| i = char ->
mk _loc (Internal (Types.char (Chars.char_class i i)))
mk _loc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class i i)))))
| i = char ; "--"; j = char ->
mk _loc (Internal (Types.char (Chars.char_class i j)))
mk _loc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class i j)))))
| "`"; c = tag_type -> c
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod _loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
......@@ -657,8 +657,9 @@ EXTEND Gram
(fun c ->
mknoloc (Internal
(Types.char
(Types.BoolChars.atom (Custom.Atm (
(Chars.atom
(Chars.V.mk_int c)))))
(Chars.V.mk_int c))))))))
(seq_of_string s) in
let s = s @ [mknoloc (Internal (Sequence.nil_type))] in
multi_prod _loc s
......
......@@ -480,7 +480,7 @@ let int_type (name,min,max) =
| None, None ->
Intervals.any
in
ignore (primitive name (Types.interval ival) (validate_interval ival name))
ignore (primitive name (Types.interval (Types.BoolIntervals.atom (Custom.Atm ival))) (validate_interval ival name))
let () =
List.iter int_type [
......
......@@ -192,9 +192,8 @@ let simple_union name members =
let xsi_nil_atom = Atoms.V.mk (Schema_xml.xsi, Utf8.mk "nil")
let xsi_nil_type = Types.atom (Atoms.atom xsi_nil_atom)
let xsi_nil_type = Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.atom xsi_nil_atom)))
let xsi_nil_label = Ns.Label.mk (Schema_xml.xsi, Utf8.mk "nil")
let merge_attribute_uses l =
List.fold_left (fun (l,a) (l',a') -> (l @ l', a || a')) ([],false) l
......@@ -13,7 +13,7 @@ module BoolChars : S = struct
let mk_atm c = atom (Custom.Atm (Chars.atom (Chars.V.mk_char c.[0] )))
end
module BoolAtoms = struct
module BoolAtoms : S with type bt = Atoms.t = struct
include BoolVar.Make(Atoms)
let mk_var s = atom (Custom.Var s)
let mk_atm s = atom (Custom.Atm (Atoms.atom (Atoms.V.mk_ascii s)))
......@@ -65,7 +65,7 @@ module BoolPair = BoolVar.Make(Pair)
module BoolRec = BoolVar.Make(Rec)
*)
let boolvar_tests_atoms = [
let atoms_tests = [
"commutativity intersection", BAP.os "atm foo ^ atm bar", BAP.os "atm bar ^ atm foo";
"commutativity union", BAP.os "atm foo v atm bar", BAP.os "atm bar v atm foo";
"distributive intersection", BAP.os "(atm foo v atm bar) ^ atm baz", BAP.os "(atm foo ^ atm baz) v (atm bar ^ atm baz)";
......@@ -79,25 +79,42 @@ let boolvar_tests_atoms = [
"splitvar atm 1", snd(BoolAtoms.splitvars (BAP.os "var alpha v (atm foo ^ var beta) v var gamma")), BAP.os "atm foo ^ var beta";
"splitvar atm 2", snd(BoolAtoms.splitvars (BAP.os "var alpha v atm foo")), BAP.os "atm foo";
"splitvar vars 2", fst(BoolAtoms.splitvars (BAP.os "var alpha v atm foo")), BAP.os "var alpha";
];;
let test_boolvar_atoms =
"test boolvar atoms" >:::
let atoms_structure =
"atoms structure" >:::
List.map (fun (descr, s1,s2) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
(*
List.iter (fun f -> f Format.std_formatter ) (BoolAtoms.print "Empty!" s1);
Format.printf "\n";
List.iter (fun f -> f Format.std_formatter ) (BoolAtoms.print "Empty!" s2);
Format.printf "\n";
*)
assert_equal (BoolAtoms.equal s1 s2) true
)
) boolvar_tests_atoms
) atoms_tests
;;
let atoms_contains =
"atoms contains" >:::
List.map (fun (descr, i, s) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
let a = Atoms.V.mk_ascii i in
let t = BAP.os s in
assert_equal (Atoms.contains a (BoolAtoms.get t)) true
)
)
[
"foo in atm foo","foo","atm foo";
"foo in (atm foo v atm bar)","foo","atm foo v atm bar";
"foo in (atm foo v atm bar) ^ ^ var beta","foo","(atm foo v atm bar) ^ var beta";
]
;;
let all =
"all tests" >::: [
test_boolvar_atoms;
atoms_structure;
]
let main () =
......
......@@ -2,7 +2,6 @@ open OUnit
(* open Types *)
let parse_typ s =
let st = Stream.of_string s in
let astpat = Parser.pat st in
......
......@@ -27,15 +27,13 @@ let print_symbolset ns ppf = function
include SortedList.FiniteCofiniteMap(Ns.Uri)(SymbolSet)
let atom l =
atom (fst (V.value l), l)
let atom l = atom (fst (V.value l), l)
(* this is to have a uniform signature of all basic types *)
type elem = V.t
let full = any
let contains l t =
contains (fst (V.value l), l) t
let contains l t = contains (fst (V.value l), l) t
let single s = match get s with
| `Finite [_, SymbolSet.Finite [a]] -> a
......
......@@ -2,7 +2,7 @@ let (<) : int -> int -> bool = (<)
let (>) : int -> int -> bool = (>)
let (=) : int -> int -> bool = (=)
(* this is the the of the Constructor container *)
module type E =
sig
type elem
......@@ -19,11 +19,14 @@ end
module type S =
sig
type bt
type elem
include Custom.T
val get: t -> (elem list * elem list) list
val get': t -> (elem list * (elem list) list) list
(* returns the union of all leaves in the BDD *)
val get: t -> bt
(* val get': t -> (elem list * (elem list) list) list *)
val empty : t
val full : t
......@@ -48,6 +51,7 @@ sig
val print: string -> t -> (Format.formatter -> unit) list
val trivially_disjoint: t -> t -> bool
end
(* ternary BDD
......@@ -77,6 +81,7 @@ struct
(* Custom.Atm are containers (Atoms, Chars, Intervals, Pairs ... )
* Custom.Var are String
*)
type bt = T.t
module X = Custom.Var(T)
type elem = T.t Custom.pairvar
type t =
......@@ -170,35 +175,7 @@ struct
| False -> []
| c -> [ fun ppf -> print X.dump ppf c ]
(* XXX : since every path contains 1 Atm, I should be able to
* descend on the first path and get a sample from the leaf *)
let rec sample = function
| Split (_,Custom.Var _, p,i,n) ->
begin match sample p with
|Some x -> Some x
|None ->
begin match sample i with
|Some x -> Some x
|None ->
begin match sample n with
|Some x -> Some x
|None -> None
end
end
end
| Split (_,Custom.Atm x, _,_,_) -> Some x
| _ -> None
let rec contains y x =
match x,y with
|True,_ |False,_ -> false
|Split (_,Custom.Var a, p,i,n),Custom.Var b ->
(a == b) || (contains y p) || (contains y i) || (contains y n)
|Split (_,Custom.Atm a, p,i,n),Custom.Atm b ->
((T.cap a b) == T.empty) || (contains y p) || (contains y i) || (contains y n)
|Split (_,_, p,i,n),_ ->
(contains y p) || (contains y i) || (contains y n)
(*
let rec get accu pos neg = function
| True -> (pos,neg) :: accu
| False -> accu
......@@ -210,7 +187,22 @@ struct
accu
let get x = get [] [] [] x
*)
let rec get accu = function
| True -> accu
| False -> accu
| Split (_,Custom.Atm x, True,False,False) -> x :: accu
| Split (_,Custom.Atm x, _,_,_) -> assert false
| Split (_,Custom.Var x, p,i,n) ->
let accu = get accu p in
let accu = get accu n in
let accu = get accu i in
accu
let get x = List.fold_left T.cup T.empty (get [] x)
(*
let rec get' accu pos neg = function
| True -> (pos,neg) :: accu
| False -> accu
......@@ -226,6 +218,7 @@ struct
aux [x] i
let get' x = get' [] [] [] x
*)
let compute ~empty ~full ~cup ~cap ~diff ~atom b =
let rec aux = function
......
......@@ -13,7 +13,7 @@ let types =
"Empty", Types.empty;
"Any", any;
"Int", int;
"Char", Types.char Chars.any;
"Char", Types.char (Types.BoolChars.atom (Custom.Atm ( Chars.any )));
"Byte", char_latin1;
"Atom", atom;
"Pair", Types.Product.any;
......@@ -167,7 +167,7 @@ binary_op_cst ">"
(* I/O *)
register_fun "char_of_int"
int (Types.char Chars.any)
int (Types.char (Types.BoolChars.atom (Custom.Atm ( Chars.any ) )))
(function
| Value.Integer x ->
(try Value.Char (Chars.V.mk_int (Intervals.V.get_int x))
......@@ -175,7 +175,7 @@ register_fun "char_of_int"
| _ -> assert false);;
register_fun "int_of_char"
(Types.char Chars.any) int
(Types.char (Types.BoolChars.atom (Custom.Atm ( Chars.any) ))) int
(function
| Value.Char x ->
Value.Integer (Intervals.V.from_int (Chars.V.to_int x))
......@@ -339,14 +339,20 @@ binary_op_cst "dump_to_file_utf8"
(* Integer operators *)
let intop f x y =
let s = Types.BoolIntervals.get x in
let t = Types.BoolIntervals.get y in
Types.BoolIntervals.atom (Custom.Atm (f s t))
;;
binary_op_gen "+"
(fun arg1 arg2 constr precise ->
let t1 = arg1 (Types.cup int Types.Record.any) true in
if Types.subtype t1 int
then (
let t2 = arg2 int true in
Types.interval
(Intervals.add (Types.Int.get t1) (Types.Int.get t2))
Types.interval
(intop Intervals.add (Types.Int.get t1) (Types.Int.get t2))
)
else if Types.subtype t1 Types.Record.any
then (
......@@ -360,7 +366,7 @@ binary_op "-"
int int
(fun t1 t2 ->
Types.interval
(Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
(intop Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
(fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
| _ -> assert false);;
......@@ -369,7 +375,7 @@ binary_op "*"
int int
(fun t1 t2 ->
Types.interval
(Intervals.mul (Types.Int.get t1) (Types.Int.get t2)))
(intop Intervals.mul (Types.Int.get t1) (Types.Int.get t2)))
(fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y)
| _ -> assert false);;
......
open Encodings
let pos_int = Types.interval (Intervals.right (Intervals.V.mk "1"))
let non_neg_int = Types.interval (Intervals.right (Intervals.V.mk "0"))
let neg_int = Types.interval (Intervals.left (Intervals.V.mk "-1"))
let non_pos_int = Types.interval (Intervals.left (Intervals.V.mk "0"))
let pos_int = Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.right (Intervals.V.mk "1"))))
let non_neg_int = Types.interval (Types.BoolIntervals.atom (Custom.Atm(Intervals.right (Intervals.V.mk "0"))))
let neg_int = Types.interval (Types.BoolIntervals.atom (Custom.Atm(Intervals.left (Intervals.V.mk "-1"))))
let non_pos_int = Types.interval (Types.BoolIntervals.atom (Custom.Atm(Intervals.left (Intervals.V.mk "0"))))
let mk_interval_type l r =
Types.interval (Intervals.bounded (Intervals.V.mk l) (Intervals.V.mk r))
Types.interval (Types.BoolIntervals.atom (Custom.Atm(Intervals.bounded (Intervals.V.mk l) (Intervals.V.mk r))))
let long_int = mk_interval_type "-9223372036854775808" "9223372036854775807"
let int_int = mk_interval_type "-2147483648" "2147483647"
let short_int = mk_interval_type "-32768" "32767"
......@@ -17,58 +17,58 @@ let byte_int = mk_interval_type "0" "255"
let non_zero_int = Types.cup pos_int neg_int
let decimal_intstr =
Sequence.plus (Types.char (Chars.char_class
Sequence.plus (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '9')
)
)
)))
let octal_intstr =
Sequence.plus (Types.char (Chars.char_class
Sequence.plus (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '7')
)
)
)))
let binary_intstr =
Sequence.plus (Types.char (Chars.char_class
Sequence.plus (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '1')
)
)
)))
let hex_intstr =
Sequence.plus (
Types.cup
(Types.char (Chars.char_class
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '9')
)
)
)))
(Types.cup
(Types.char (Chars.char_class
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Chars.V.mk_char 'a')
(Chars.V.mk_char 'f')
)
)
(Types.char (Chars.char_class
)))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Chars.V.mk_char 'A')
(Chars.V.mk_char 'F')
)
)
)))
)
)
let hex_str =
Types.times
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Chars.atom (Chars.V.mk_char 'X')))
(Types.char (Chars.atom (Chars.V.mk_char 'x')))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'X')))))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'x')))))
)
)
(Types.cons hex_intstr)
......@@ -77,13 +77,13 @@ let hex_str =
let oct_str =
Types.times
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Chars.atom (Chars.V.mk_char 'O')))
(Types.char (Chars.atom (Chars.V.mk_char 'o')))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'O')))))
(Types.char (Types.BoolChars.atom (Custom.Atm(Chars.atom (Chars.V.mk_char 'o')))))
)
)
(Types.cons octal_intstr)
......@@ -93,13 +93,13 @@ let oct_str =
let bin_str =
Types.times
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Chars.atom (Chars.V.mk_char 'B')))
(Types.char (Chars.atom (Chars.V.mk_char 'b')))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'B')))))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'b')))))
)
)
(Types.cons binary_intstr)
......@@ -107,15 +107,11 @@ let bin_str =
)
let pos_intstr =
Types.cup
decimal_intstr (Types.cup
hex_str (Types.cup
bin_str
oct_str))
Types.cup decimal_intstr (Types.cup hex_str (Types.cup bin_str oct_str))
let neg_intstr =
Types.times
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '-'))))
(Types.cons (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char '-'))))))
(Types.cons pos_intstr)
let intstr = Types.cup pos_intstr neg_intstr (* [ '-'? '0'--'9'+ ] *)
......@@ -123,8 +119,8 @@ let intstr = Types.cup pos_intstr neg_intstr (* [ '-'? '0'--'9'+ ] *)
let true_atom = Atoms.V.mk_ascii "true"
let false_atom = Atoms.V.mk_ascii "false"
let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)