Commit a2da41f0 authored by Pietro Abate's avatar Pietro Abate
Browse files

Adapt Types.Descr.t to use the new BDD base data structure

parent 1c1ca633
...@@ -8,8 +8,8 @@ true: -traverse ...@@ -8,8 +8,8 @@ true: -traverse
<compile>: include <compile>: include
<schema>: include <schema>: include
<runtime>: 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_test)
<{misc,types}/*.cmx>: for-pack(Cduce_boolvar) <{misc,types}/*.cmx>: for-pack(Cduce_boolvar)
<parser/**>: package(ulex), package(netstring), syntax(camlp4o) <parser/**>: package(ulex), package(netstring), syntax(camlp4o)
......
...@@ -17,4 +17,3 @@ Normal ...@@ -17,4 +17,3 @@ Normal
Pretty Pretty
Stats Stats
BoolVar BoolVar
Types
...@@ -10,6 +10,7 @@ SortedList ...@@ -10,6 +10,7 @@ SortedList
Atoms Atoms
Bool Bool
Chars Chars
BoolVar
Ident Ident
Intervals Intervals
Inttbl Inttbl
...@@ -23,7 +24,6 @@ Parser ...@@ -23,7 +24,6 @@ Parser
Builtin_defs Builtin_defs
Cduce_loc Cduce_loc
Sequence Sequence
Sample
Patterns Patterns
Lambda Lambda
Value Value
......
...@@ -170,21 +170,22 @@ module Sum(X : T)(Y : T) = struct ...@@ -170,21 +170,22 @@ module Sum(X : T)(Y : T) = struct
| Right t -> Format.fprintf ppf "R%a" Y.dump t | Right t -> Format.fprintf ppf "R%a" Y.dump t
end end
type 'a pairvar = Atm of 'a | Var of String.t type var = [ `Var of String.t ]
type 'a pairvar = [ `Atm of 'a | var ]
module Var (X : T) = struct module Var (X : T) = struct
type t = X.t pairvar type t = X.t pairvar
let hash = function Atm t -> X.hash t | Var s -> String.hash s let hash = function `Atm t -> X.hash t | `Var s -> (* String.hash s *) Hashtbl.hash (`Var s)
let check = function Atm t -> X.check t | Var _ -> () let check = function `Atm t -> X.check t | `Var _ -> ()
let compare t1 t2 = let compare t1 t2 =
match t1,t2 with match t1,t2 with
|Atm x, Atm y -> X.compare x y |`Atm x, `Atm y -> X.compare x y
|Var x, Var y -> String.compare x y |`Var x, `Var y -> String.compare x y
|Var _, Atm _ -> -1 |`Var _, `Atm _ -> -1
|Atm _, Var _ -> 1 |`Atm _, `Var _ -> 1
let equal t1 t2 = (compare t1 t2) = 0 let equal t1 t2 = (compare t1 t2) = 0
let dump ppf = function let dump ppf = function
|Atm x -> X.dump ppf x |`Atm x -> X.dump ppf x
|Var x -> String.dump ppf x |`Var x -> String.dump ppf x
end end
...@@ -46,7 +46,7 @@ and pexpr = ...@@ -46,7 +46,7 @@ and pexpr =
(* CDuce is a Lambda-calculus ... *) (* CDuce is a Lambda-calculus ... *)
| Var of U.t | Var of U.t
| TVar of Types.Vars.V.t | TVar of BoolVar.Vars.V.t
| Apply of pexpr * pexpr | Apply of pexpr * pexpr
| Abstraction of abstr | Abstraction of abstr
......
...@@ -62,7 +62,7 @@ let tuple_queue = ...@@ -62,7 +62,7 @@ let tuple_queue =
List.fold_right (fun x q -> Pair (x, q)) List.fold_right (fun x q -> Pair (x, q))
let char = mknoloc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm Chars.any)))) let char = mknoloc (Internal (Types.char (Types.BoolChars.atom (`Atm Chars.any))))
let string_regexp = Star (Elem char) let string_regexp = Star (Elem char)
let seq_of_string s = let seq_of_string s =
...@@ -298,7 +298,7 @@ EXTEND Gram ...@@ -298,7 +298,7 @@ EXTEND Gram
| e1 = expr; "&&"; e2 = expr -> exp _loc (logical_and e1 e2) | e1 = expr; "&&"; e2 = expr -> exp _loc (logical_and e1 e2)
| e = expr; op = "/"; p = pat LEVEL "simple" -> | e = expr; op = "/"; p = pat LEVEL "simple" ->
(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *) (* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.any))))) in let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let att = mk _loc (Internal Types.Record.any) in let att = mk _loc (Internal Types.Record.any) in
let any = mk _loc (Internal Types.any) in let any = mk _loc (Internal Types.any) in
let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
...@@ -307,7 +307,7 @@ EXTEND Gram ...@@ -307,7 +307,7 @@ EXTEND Gram
exp _loc (Transform (e,[p, Var id_dummy])) exp _loc (Transform (e,[p, Var id_dummy]))
| e = expr; "/@"; a = ident_or_keyword -> | e = expr; "/@"; a = ident_or_keyword ->
(* transform e with <(Atom) {a=$$$}>_ -> [$$$] *) (* transform e with <(Atom) {a=$$$}>_ -> [$$$] *)
let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.any))))) in let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let any = mk _loc (Internal Types.any) in let any = mk _loc (Internal Types.any) in
let att = mk _loc (Record let att = mk _loc (Record
(true, [(label a, (true, [(label a,
...@@ -330,7 +330,7 @@ EXTEND Gram ...@@ -330,7 +330,7 @@ EXTEND Gram
set_ref set_ref
(Var stk) (Var stk)
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in (concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
let tag = mknoloc (Internal (Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.any))))) in let tag = mknoloc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let att = mknoloc (Internal Types.Record.any) in let att = mknoloc (Internal Types.Record.any) in
let any = mknoloc (Internal Types.any) in let any = mknoloc (Internal Types.any) in
let re = (SeqCapture(noloc,y,Star(Elem(any)))) in let re = (SeqCapture(noloc,y,Star(Elem(any)))) in
...@@ -403,7 +403,7 @@ EXTEND Gram ...@@ -403,7 +403,7 @@ EXTEND Gram
tag: [ [ a = ident_or_keyword -> exp _loc (Atom (ident a)) ] ]; tag: [ [ a = ident_or_keyword -> exp _loc (Atom (ident a)) ] ];
tag_type: [ tag_type: [
[ "_" -> mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.any))))) [ "_" -> mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any)))))
| "$"; a = ident_or_keyword -> mk _loc (Cst (TVar a)) | "$"; a = ident_or_keyword -> mk _loc (Cst (TVar a))
| a = ident_or_keyword -> mk _loc (Cst (Atom (ident a))) | a = ident_or_keyword -> mk _loc (Cst (Atom (ident a)))
| t = ANY_IN_NS -> mk _loc (NsT (ident t)) | t = ANY_IN_NS -> mk _loc (NsT (ident t))
...@@ -569,13 +569,13 @@ EXTEND Gram ...@@ -569,13 +569,13 @@ EXTEND Gram
| i = STRING1; "--"; j = STRING1 -> | i = STRING1; "--"; j = STRING1 ->
let i = Chars.V.mk_int (parse_char _loc i) let i = Chars.V.mk_int (parse_char _loc i)
and j = Chars.V.mk_int (parse_char _loc j) in and j = Chars.V.mk_int (parse_char _loc j) in
Elem (mk _loc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class i j)))))) Elem (mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i j))))))
| s = STRING1 -> | s = STRING1 ->
List.fold_right List.fold_right
(fun c accu -> (fun c accu ->
let c = Chars.V.mk_int c in let c = Chars.V.mk_int c in
let c = Chars.atom c in let c = Chars.atom c in
Seq (Elem (mknoloc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm c))))), accu)) Seq (Elem (mknoloc (Internal (Types.char (Types.BoolChars.atom (`Atm c))))), accu))
(seq_of_string s) (seq_of_string s)
Epsilon ] Epsilon ]
| [ e = pat LEVEL "simple" -> Elem e | [ e = pat LEVEL "simple" -> Elem e
...@@ -619,20 +619,20 @@ EXTEND Gram ...@@ -619,20 +619,20 @@ EXTEND Gram
| i = INT ; "--"; j = INT -> | i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i let i = Intervals.V.mk i
and j = Intervals.V.mk j in and j = Intervals.V.mk j in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.bounded i j))))) mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.bounded i j)))))
| i = INT -> | i = INT ->
let i = Intervals.V.mk i in let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.atom i))))) mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.atom i)))))
| "*"; "--"; j = INT -> | "*"; "--"; j = INT ->
let j = Intervals.V.mk j in let j = Intervals.V.mk j in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.left j))))) mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.left j)))))
| i = INT; "--"; "*" -> | i = INT; "--"; "*" ->
let i = Intervals.V.mk i in let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.right i))))) mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.right i)))))
| i = char -> | i = char ->
mk _loc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class i i))))) mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i i)))))
| i = char ; "--"; j = char -> | i = char ; "--"; j = char ->
mk _loc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class i j))))) mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i j)))))
| "`"; c = tag_type -> c | "`"; c = tag_type -> c
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod _loc l | "("; l = LIST1 pat SEP ","; ")" -> multi_prod _loc l
| "["; r = [ r = regexp -> r | -> Epsilon ]; | "["; r = [ r = regexp -> r | -> Epsilon ];
...@@ -657,7 +657,7 @@ EXTEND Gram ...@@ -657,7 +657,7 @@ EXTEND Gram
(fun c -> (fun c ->
mknoloc (Internal mknoloc (Internal
(Types.char (Types.char
(Types.BoolChars.atom (Custom.Atm ( (Types.BoolChars.atom (`Atm (
(Chars.atom (Chars.atom
(Chars.V.mk_int c)))))))) (Chars.V.mk_int c))))))))
(seq_of_string s) in (seq_of_string s) in
......
...@@ -480,7 +480,7 @@ let int_type (name,min,max) = ...@@ -480,7 +480,7 @@ let int_type (name,min,max) =
| None, None -> | None, None ->
Intervals.any Intervals.any
in in
ignore (primitive name (Types.interval (Types.BoolIntervals.atom (Custom.Atm ival))) (validate_interval ival name)) ignore (primitive name (Types.interval (Types.BoolIntervals.atom (`Atm ival))) (validate_interval ival name))
let () = let () =
List.iter int_type [ List.iter int_type [
......
...@@ -192,7 +192,7 @@ let simple_union name members = ...@@ -192,7 +192,7 @@ let simple_union name members =
let xsi_nil_atom = Atoms.V.mk (Schema_xml.xsi, Utf8.mk "nil") let xsi_nil_atom = Atoms.V.mk (Schema_xml.xsi, Utf8.mk "nil")
let xsi_nil_type = Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.atom xsi_nil_atom))) let xsi_nil_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom xsi_nil_atom)))
let xsi_nil_label = Ns.Label.mk (Schema_xml.xsi, Utf8.mk "nil") let xsi_nil_label = Ns.Label.mk (Schema_xml.xsi, Utf8.mk "nil")
let merge_attribute_uses l = let merge_attribute_uses l =
......
...@@ -7,22 +7,28 @@ module type S = sig ...@@ -7,22 +7,28 @@ module type S = sig
val mk_atm : string -> t val mk_atm : string -> t
end end
module BoolChars : S = struct module BoolChars : S with type s = Chars.t = struct
include BoolVar.Make(Chars) include BoolVar.Make(Chars)
let mk_var s = atom (Custom.Var s) let mk_var s = atom (`Var s)
let mk_atm c = atom (Custom.Atm (Chars.atom (Chars.V.mk_char c.[0] ))) let mk_atm c = atom (`Atm (Chars.atom (Chars.V.mk_char c.[0] )))
end end
module BoolAtoms : S with type bt = Atoms.t = struct module BoolAtoms : S with type s = Atoms.t = struct
include BoolVar.Make(Atoms) include BoolVar.Make(Atoms)
let mk_var s = atom (Custom.Var s) let mk_var s = atom (`Var s)
let mk_atm s = atom (Custom.Atm (Atoms.atom (Atoms.V.mk_ascii s))) let mk_atm s = atom (`Atm (Atoms.atom (Atoms.V.mk_ascii s)))
end end
module BoolIntervals : S = struct module BoolIntervals : S with type s = Intervals.t = struct
include BoolVar.Make(Intervals) include BoolVar.Make(Intervals)
let mk_var s = atom (Custom.Var s) let mk_var s = atom (`Var s)
let mk_atm s = atom (Custom.Atm (Intervals.atom (Intervals.V.mk s))) let mk_atm s = atom (`Atm (Intervals.atom (Intervals.V.mk s)))
end
module BoolVars : S with type s = BoolVar.Vars.t = struct
include BoolVar.BoolVars
let mk_var s = atom (`Var s)
let mk_atm s = failwith "AA"
end end
module ExprParser (B : S) = struct module ExprParser (B : S) = struct
...@@ -58,6 +64,7 @@ end ...@@ -58,6 +64,7 @@ end
module BCP = ExprParser(BoolChars) module BCP = ExprParser(BoolChars)
module BAP = ExprParser(BoolAtoms) module BAP = ExprParser(BoolAtoms)
module BIP = ExprParser(BoolIntervals) module BIP = ExprParser(BoolIntervals)
module BVP = ExprParser(BoolVars)
(* (*
XXX this needs much more infrastructure as in types.ml XXX this needs much more infrastructure as in types.ml
...@@ -73,14 +80,59 @@ let atoms_tests = [ ...@@ -73,14 +80,59 @@ let atoms_tests = [
"associativity union", BAP.os "(atm foo v atm bar) v atm baz", BAP.os "atm foo v (atm bar v atm baz)"; "associativity union", BAP.os "(atm foo v atm bar) v atm baz", BAP.os "atm foo v (atm bar v atm baz)";
"difference", BAP.os "(atm foo ^ atm bar) v var alpha", BAP.os "var alpha"; "difference", BAP.os "(atm foo ^ atm bar) v var alpha", BAP.os "var alpha";
"difference empty", BAP.os "atm foo ^ atm bar", BAP.os "Empty"; "difference empty", BAP.os "atm foo ^ atm bar", BAP.os "Empty";
"splitvar vars empty", fst(BoolAtoms.splitvars (BAP.os "atm foo")), BAP.os "Empty";
"splitvar atm empty", snd(BoolAtoms.splitvars (BAP.os "var alpha")), BAP.os "Empty";
"splitvar vars 1 ", fst(BoolAtoms.splitvars (BAP.os "var alpha v (atm foo ^ var beta) v var gamma")), BAP.os "var alpha v var gamma";
"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 atoms_splitvar_vars =
"vars splitvar" >:::
List.map (fun (descr, s1,s2) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
assert_equal (BoolVar.BoolVars.equal ( s1 :> BoolVar.BoolVars.t ) s2) true
)
) [
"vars empty", fst(BoolAtoms.extractvars (BAP.os "atm foo")), BVP.os "Empty";
"vars 1 ", fst(BoolAtoms.extractvars (BAP.os "var alpha v (atm foo ^ var beta) v var gamma")), BVP.os "var alpha v var gamma";
"vars 2", fst(BoolAtoms.extractvars (BAP.os "var alpha v atm foo")), BVP.os "var alpha";
"vars 2", fst(BoolAtoms.extractvars (BAP.os "var alpha v atm foo")), fst(BoolChars.extractvars (BCP.os "var alpha v atm c"));
]
;;
let atoms_splitvar_atm =
"atoms splitvar" >:::
List.map (fun (descr, s1,s2) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
assert_equal (BoolAtoms.equal s1 s2) true
)
) [
"atm empty", snd(BoolAtoms.extractvars (BAP.os "var alpha")), BAP.os "Empty";
"atm 1", snd(BoolAtoms.extractvars (BAP.os "var alpha v (atm foo ^ var beta) v var gamma")), BAP.os "atm foo ^ var beta";
"atm 2", snd(BoolAtoms.extractvars (BAP.os "var alpha v atm foo")), BAP.os "atm foo";
]
;;
let splitvar_mixed_union_var =
"splitvar union" >:::
List.map (fun (descr, s1,s2,r) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
assert_equal (BoolVar.BoolVars.equal (BoolVar.BoolVars.cup s1 s2) r) true
)
) [
"atoms/chars", fst(BoolAtoms.extractvars (BAP.os "atm foo")), fst(BoolChars.extractvars (BCP.os "var alpha v atm x")), BVP.os "var alpha";
"atoms/chars", fst(BoolAtoms.extractvars (BAP.os "var alpha v atm foo")), fst(BoolChars.extractvars (BCP.os "var alpha v atm c")), BVP.os "var alpha";
]
;;
let splitvar_mixed_union_atm =
"splitvar union" >:::
List.map (fun (descr, s1,s2,r) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
assert_equal (BoolAtoms.equal (BoolAtoms.cup s1 s2) r) true
)
) [
"atoms/chars", snd(BoolAtoms.extractvars (BAP.os "atm foo")), fst(BoolChars.extractvars (BCP.os "var alpha v atm x")), BAP.os "var alpha v atm foo";
]
;;
let atoms_structure = let atoms_structure =
"atoms structure" >::: "atoms structure" >:::
List.map (fun (descr, s1,s2) -> List.map (fun (descr, s1,s2) ->
...@@ -115,6 +167,11 @@ let atoms_contains = ...@@ -115,6 +167,11 @@ let atoms_contains =
let all = let all =
"all tests" >::: [ "all tests" >::: [
atoms_structure; atoms_structure;
atoms_contains;
atoms_splitvar_atm;
atoms_splitvar_vars;
splitvar_mixed_union_atm;
splitvar_mixed_union_var
] ]
let main () = let main () =
......
...@@ -17,7 +17,15 @@ Types.subtype t1 t2 ;; ...@@ -17,7 +17,15 @@ Types.subtype t1 t2 ;;
let subtype_tests = [ let subtype_tests = [
"Int" , "Any", true; "Int" , "Any", true;
"`a | Int" , "`a", false; "`A | Int" , "`A", false;
"`A | ( 0--* | *--0)" , "`A", false;
"42 | Int" , "42", false;
"Int" , "Empty", false;
"'c' | Int" , "1", false;
"`A | Char" , "`A", false;
"`A | (`A,`B)" , "`A", false;
"`A -> `B | Int" , "`A -> `B", false;
"(`A,`B) | Int" , "(`A,`B)", false;
"Any" , "Any", true; "Any" , "Any", true;
"Empty" , "Empty", true; "Empty" , "Empty", true;
"Empty" , "Any", true; "Empty" , "Any", true;
...@@ -28,17 +36,16 @@ let subtype_tests = [ ...@@ -28,17 +36,16 @@ let subtype_tests = [
"1--5" , "1--*", true; "1--5" , "1--*", true;
"1--5" , "1--5", true; "1--5" , "1--5", true;
"Any -> `a" , "Any", true; "Any -> `A" , "Any", true;
"`a -> `b | Int" , "`a -> `b", false;
"`a -> `b" , "`a -> `b", true; "`A -> `B" , "`A -> `B", true;
"Any -> `a" , "Any -> Any", true; "Any -> `a" , "Any -> Any", true;
"`a -> `b" , "Empty -> Any", true; "`A -> `B" , "Empty -> Any", true;
"(`a -> `c) | (`b -> `c)" , "(`a & `b) -> `c", true; "(`A -> `C) | (`B -> `C)" , "(`A & `B) -> `C", true;
"(`a & `b) | (`a & `c)" , "`a & (`b | `c)", true; "(`A & `B) | (`A & `C)" , "`A & (`B | `C)", true;
"`a & (`b | `c)" , "(`a & `b) | (`a & `c)", true; "`A & (`B | `C)" , "(`A & `B) | (`A & `C)", true;
"(`a,`b) | (`c,`d)" , "((`a | `c) , (`b | `d))", true; "(`A,`B) | (`C,`D)" , "((`A | `C) , (`B | `D))", true;
"(`a , `b & `c)" , "(`a,`b) & (`a,`c)", true; "(`A , `B & `C)" , "(`A,`B) & (`A,`C)", true;
(* (*
"mu x . Int -> (Nat , x)" , "mu x . Nat -> (Int , x)", true; "mu x . Int -> (Nat , x)" , "mu x . Nat -> (Int , x)", true;
"mu x . (a,x)" , "mu y . (a,y)", true; "mu x . (a,x)" , "mu y . (a,y)", true;
...@@ -46,16 +53,21 @@ let subtype_tests = [ ...@@ -46,16 +53,21 @@ let subtype_tests = [
"Any" , "Int", false ; "Any" , "Int", false ;
"Any" , "Empty", false ; "Any" , "Empty", false ;
"`a -> `b" , "`a", false ; "`A -> `B" , "`A", false ;
"Any -> `a" , "Empty", false ; "Any -> `A" , "Empty", false ;
"Any -> `a" , "Any -> Empty", false ; "Any -> `A" , "Any -> Empty", false ;
"`a -> `b" , "`a -> `c", false ; "`A -> `B" , "`A -> `C", false ;
"Int" , "0--*", false ; "Int" , "0--*", false ;
"1--5" , "1--4", false ; "1--5" , "1--4", false ;
"Int" , "0--*", false ; "Int" , "0--*", false ;
"`$X" , "Any", true; "`$X" , "Any", true;
"`$X | Int" , "Any", true;
"Any", "`$X | (Any \\ `$X)", true;
"Any", "(42 & `$X) | (Any \\ (42 & `$X))", true;
"Any", "(41 & `$X) | (Any \\ (42 & `$X))", false;
"Any", "Any \\ Char", false;
];; ];;
let test_subtype = let test_subtype =
...@@ -64,7 +76,7 @@ let test_subtype = ...@@ -64,7 +76,7 @@ let test_subtype =
(Printf.sprintf " %s <: %s " s1 s2) >:: (fun _ -> (Printf.sprintf " %s <: %s " s1 s2) >:: (fun _ ->
let t1 = parse_typ s1 in let t1 = parse_typ s1 in
let t2 = parse_typ s2 in let t2 = parse_typ s2 in
let result = Types.subtype t1 t2 in let result = Types.subtype t1 t2 in
if result <> expected then if result <> expected then
begin begin
(* Printf.printf "subtyping error %s <: %s\n" s1 s2; *) (* Printf.printf "subtyping error %s <: %s\n" s1 s2; *)
......
This diff is collapsed.
...@@ -13,7 +13,7 @@ let types = ...@@ -13,7 +13,7 @@ let types =
"Empty", Types.empty; "Empty", Types.empty;
"Any", any; "Any", any;
"Int", int; "Int", int;
"Char", Types.char (Types.BoolChars.atom (Custom.Atm ( Chars.any ))); "Char", Types.char (Types.BoolChars.atom (`Atm ( Chars.any )));
"Byte", char_latin1; "Byte", char_latin1;
"Atom", atom; "Atom", atom;
"Pair", Types.Product.any; "Pair", Types.Product.any;
...@@ -167,7 +167,7 @@ binary_op_cst ">" ...@@ -167,7 +167,7 @@ binary_op_cst ">"
(* I/O *) (* I/O *)
register_fun "char_of_int" register_fun "char_of_int"
int (Types.char (Types.BoolChars.atom (Custom.Atm ( Chars.any ) ))) int (Types.char (Types.BoolChars.atom (`Atm ( Chars.any ) )))
(function (function
| Value.Integer x -> | Value.Integer x ->
(try Value.Char (Chars.V.mk_int (Intervals.V.get_int x)) (try Value.Char (Chars.V.mk_int (Intervals.V.get_int x))
...@@ -175,7 +175,7 @@ register_fun "char_of_int" ...@@ -175,7 +175,7 @@ register_fun "char_of_int"
| _ -> assert false);; | _ -> assert false);;
register_fun "int_of_char" register_fun "int_of_char"
(Types.char (Types.BoolChars.atom (Custom.Atm ( Chars.any) ))) int (Types.char (Types.BoolChars.atom (`Atm ( Chars.any) ))) int
(function (function
| Value.Char x -> | Value.Char x ->
Value.Integer (Intervals.V.from_int (Chars.V.to_int x)) Value.Integer (Intervals.V.from_int (Chars.V.to_int x))
...@@ -342,7 +342,7 @@ binary_op_cst "dump_to_file_utf8" ...@@ -342,7 +342,7 @@ binary_op_cst "dump_to_file_utf8"
let intop f x y = let intop f x y =
let s = Types.BoolIntervals.get x in let s = Types.BoolIntervals.get x in
let t = Types.BoolIntervals.get y in let t = Types.BoolIntervals.get y in
Types.BoolIntervals.atom (Custom.Atm (f s t)) Types.BoolIntervals.atom (`Atm (f s t))
;;