Commit 410fcd0c authored by Pietro Abate's avatar Pietro Abate

Implementation of the Tallying problem

- revert a few chances I did before in the code
- add new unit tests functions for the Tallying problem
parent d3591e7e
......@@ -180,7 +180,9 @@ module Var (X : T) = struct
let compare t1 t2 =
match t1,t2 with
|`Atm x, `Atm y -> X.compare x y
|`Var x, `Var y -> String.compare x y
|`Var x, `Var y when x = y -> 0
(* HACK fix BoolVar.get to get variables in the correct order *)
|`Var x, `Var y -> if String.compare x y = -1 then 1 else -1
|`Var _, `Atm _ -> -1
|`Atm _, `Var _ -> 1
......
......@@ -3,9 +3,10 @@ open Ocamlbuild_plugin;;
Options.use_ocamlfind := true ;;
open Command ;;
(*
let _ = dispatch begin function
| After_rules ->
ocaml_lib ~extern:true ~dir:"_build" "typesOUnit"
| _ -> ()
end;;
*)
......@@ -40,12 +40,12 @@ and toplevel_directive =
| `Builtins
]
and pexpr =
| LocatedExpr of loc * pexpr
(* CDuce is a Lambda-calculus ... *)
| Var of U.t
(* this TVar must be moved to patt *)
| TVar of BoolVar.Vars.V.t
| Apply of pexpr * pexpr
| Abstraction of abstr
......@@ -80,7 +80,6 @@ and pexpr =
| Check of pexpr * ppat
| Ref of pexpr * ppat
(* CQL *)
| SelectFW of pexpr * (ppat * pexpr) list * pexpr list
......@@ -90,6 +89,14 @@ and abstr = {
fun_name : (Cduce_loc.loc * U.t) option;
fun_iface : (ppat * ppat) list;
fun_body : branches
(* add deco : (sigma) symbolic representation of set type substitutions *)
(* plus a flag that is true if interesection of the free varbialbes of S that are not intruduced
* by the lambda astractions are domain of sigma.
* if oldvar(S) ^ dom(sigma) = empty then s < t else s[eval(sigma, env)] < t
* (biginter_{sigma_i \in eval} s (sigma_i) ) < t
*
* see Evaluation, section 5.3 Article part 1
* *)
}
and branches = (ppat * pexpr) list
......
......@@ -62,7 +62,7 @@ let tuple_queue =
List.fold_right (fun x q -> Pair (x, q))
let char = mknoloc (Internal (Types.char (Types.BoolChars.atom (`Atm Chars.any))))
let char = mknoloc (Internal (Types.char 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 (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let tag = mk _loc (Internal (Types.atom 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 (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let tag = mk _loc (Internal (Types.atom 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 (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let tag = mknoloc (Internal (Types.atom 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,7 +403,7 @@ EXTEND Gram
tag: [ [ a = ident_or_keyword -> exp _loc (Atom (ident a)) ] ];
tag_type: [
[ "_" -> mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any)))))
[ "_" -> mk _loc (Internal (Types.atom 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 (Types.BoolChars.atom (`Atm (Chars.char_class i j))))))
Elem (mk _loc (Internal (Types.char (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 (Types.BoolChars.atom (`Atm c))))), accu))
Seq (Elem (mknoloc (Internal (Types.char 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 (Types.BoolIntervals.atom (`Atm (Intervals.bounded i j)))))
mk _loc (Internal (Types.interval (Intervals.bounded i j)))
| i = INT ->
let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.atom i)))))
mk _loc (Internal (Types.interval (Intervals.atom i)))
| "*"; "--"; j = INT ->
let j = Intervals.V.mk j in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.left j)))))
mk _loc (Internal (Types.interval (Intervals.left j)))
| i = INT; "--"; "*" ->
let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.right i)))))
mk _loc (Internal (Types.interval (Intervals.right i)))
| i = char ->
mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i i)))))
mk _loc (Internal (Types.char (Chars.char_class i i)))
| i = char ; "--"; j = char ->
mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i j)))))
mk _loc (Internal (Types.char (Chars.char_class i j)))
| "`"; c = tag_type -> c
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod _loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
......@@ -657,9 +657,8 @@ EXTEND Gram
(fun c ->
mknoloc (Internal
(Types.char
(Types.BoolChars.atom (`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 (Types.BoolIntervals.atom (`Atm ival))) (validate_interval ival name))
ignore (primitive name (Types.interval ival) (validate_interval ival name))
let () =
List.iter int_type [
......
......@@ -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_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom xsi_nil_atom)))
let xsi_nil_type = Types.atom (Atoms.atom xsi_nil_atom)
let xsi_nil_label = Ns.Label.mk (Schema_xml.xsi, Utf8.mk "nil")
let merge_attribute_uses l =
......
open OUnit
(* open Types *)
let parse_typ s =
let st = Stream.of_string s in
let astpat = Parser.pat st in
let nodepat = Typer.typ Builtin.env astpat in
Types.descr nodepat
;;
let norm_tests = [
"Int \\ (`$A | `$B)", [[(false,`Var "A",parse_typ "Int \\ `$B")]];
]
let test_norm =
"test tallying norm" >:::
List.map (fun (t,expected) ->
(Printf.sprintf " %s " t) >:: (fun _ ->
let ll = Types.Tallying.norm (parse_typ t) in
assert_equal ll expected
)
) norm_tests
;;
let all =
"all tests" >::: [
test_norm;
]
let main () =
OUnit.run_test_tt_main all
;;
main ()
......@@ -42,6 +42,8 @@ sig
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
(* vars a : return a bdd that is ( Any ^ Var a ) *)
val vars : Custom.var -> t
val iter: (elem-> unit) -> t -> unit
......@@ -196,7 +198,7 @@ struct
* of positive and negative elements on a branch *)
let get x =
let rec aux accu pos neg = function
| `True -> (pos,neg) :: accu
| `True -> (List.rev pos, List.rev neg) :: accu
| `False -> accu
| `Split (_,x, p,i,n) ->
(*OPT: can avoid creating this list cell when pos or neg =`False *)
......
......@@ -13,7 +13,7 @@ let types =
"Empty", Types.empty;
"Any", any;
"Int", int;
"Char", Types.char (Types.BoolChars.atom (`Atm ( Chars.any )));
"Char", Types.char 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 (Types.BoolChars.atom (`Atm ( Chars.any ) )))
int (Types.char 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 (Types.BoolChars.atom (`Atm ( Chars.any) ))) int
(Types.char Chars.any) int
(function
| Value.Char x ->
Value.Integer (Intervals.V.from_int (Chars.V.to_int x))
......@@ -342,7 +342,7 @@ binary_op_cst "dump_to_file_utf8"
let intop f x y =
let s = Types.BoolIntervals.leafconj x in
let t = Types.BoolIntervals.leafconj y in
Types.BoolIntervals.atom (`Atm (f s t))
(f s t)
;;
binary_op_gen "+"
......
open Encodings
let pos_int = Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.right (Intervals.V.mk "1"))))
let non_neg_int = Types.interval (Types.BoolIntervals.atom (`Atm(Intervals.right (Intervals.V.mk "0"))))
let neg_int = Types.interval (Types.BoolIntervals.atom (`Atm(Intervals.left (Intervals.V.mk "-1"))))
let non_pos_int = Types.interval (Types.BoolIntervals.atom (`Atm(Intervals.left (Intervals.V.mk "0"))))
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 mk_interval_type l r =
Types.interval (Types.BoolIntervals.atom (`Atm(Intervals.bounded (Intervals.V.mk l) (Intervals.V.mk r))))
Types.interval (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 (Types.BoolChars.atom (`Atm (Chars.char_class
Sequence.plus (Types.char (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '9')
)
)))
)
let octal_intstr =
Sequence.plus (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
Sequence.plus (Types.char (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '7')
)
)))
)
let binary_intstr =
Sequence.plus (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
Sequence.plus (Types.char (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '1')
)
)))
)
let hex_intstr =
Sequence.plus (
Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Types.char (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '9')
)
)))
)
(Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Types.char (Chars.char_class
(Chars.V.mk_char 'a')
(Chars.V.mk_char 'f')
)
)))
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
)
(Types.char (Chars.char_class
(Chars.V.mk_char 'A')
(Chars.V.mk_char 'F')
)
)))
)
)
)
let hex_str =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'X')))))
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'x')))))
(Types.char (Chars.atom (Chars.V.mk_char 'X')))
(Types.char (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 (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'O')))))
(Types.char (Types.BoolChars.atom (`Atm(Chars.atom (Chars.V.mk_char 'o')))))
(Types.char (Chars.atom (Chars.V.mk_char 'O')))
(Types.char (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 (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'B')))))
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'b')))))
(Types.char (Chars.atom (Chars.V.mk_char 'B')))
(Types.char (Chars.atom (Chars.V.mk_char 'b')))
)
)
(Types.cons binary_intstr)
......@@ -111,7 +111,7 @@ let pos_intstr =
let neg_intstr =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '-'))))))
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '-'))))
(Types.cons pos_intstr)
let intstr = Types.cup pos_intstr neg_intstr (* [ '-'? '0'--'9'+ ] *)
......@@ -119,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 (Types.BoolAtoms.atom (`Atm (Atoms.atom true_atom)))
let false_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom false_atom)))
let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)
let bool = Types.cup true_type false_type
let nil = Sequence.nil_type
......@@ -128,15 +128,15 @@ let string = Sequence.string
let char = Types.Char.any
let any = Types.any
let int = Types.Int.any
let atom = Types.atom (Types.BoolAtoms.atom (`Atm Atoms.any))
let atom = Types.atom Atoms.any
let char_latin1 = Types.char (Types.BoolChars.atom (`Atm (Chars.mk_classes [ (0,255) ])))
let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
let string_latin1 = Sequence.star char_latin1
let time_kind =
List.fold_left (fun acc t -> Types.cup acc t) Types.empty
(List.map
(fun s -> Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom (Atoms.V.mk_ascii s)))))
(fun s -> Types.atom (Atoms.atom (Atoms.V.mk_ascii s)))
[ "duration"; "dateTime"; "time"; "date"; "gYearMonth"; "gYear";
"gMonthDay"; "gDay"; "gMonth" ])
......
......@@ -44,5 +44,5 @@ val float_abs: Types.Abstract.abs
val any_xml : Types.t
val any_xml_with_tag: Types.BoolAtoms.t -> Types.t
val any_xml_with_tag: Atoms.t -> Types.t
......@@ -6,7 +6,7 @@ exception Error of error
let nil_atom = Atoms.V.mk_ascii "nil"
let nil_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom nil_atom)))
let nil_type = Types.atom (Atoms.atom nil_atom)
let nil_node = Types.cons nil_type
let nil_cst = Types.Atom nil_atom
......@@ -225,7 +225,7 @@ let seq_of_list l =
List.fold_right times' l nil_type
let char_latin1 = Types.char (Types.BoolChars.atom (`Atm (Chars.mk_classes [ (0,255) ])))
let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
let string_latin1 = star char_latin1
......
This diff is collapsed.
......@@ -121,15 +121,15 @@ val non_constructed_or_absent : t
type pair_kind = [ `Normal | `XML ]
val interval : BoolIntervals.t -> t
val atom : BoolAtoms.t -> t
val interval : Intervals.t -> t
val atom : Atoms.t -> t
val times : Node.t -> Node.t -> t
val xml : Node.t -> Node.t -> t
val arrow : Node.t -> Node.t -> t
val record : label -> Node.t -> t
(* bool = true -> open record; bool = false -> closed record *)
val record_fields : bool * Node.t label_map -> t
val char : BoolChars.t -> t
val char : Chars.t -> t
val constant : const -> t
val abstract : Abstract.t -> t
......@@ -170,6 +170,7 @@ module Product : sig
type t = (descr * descr) list
val is_empty: t -> bool
val get: ?kind:pair_kind -> descr -> t
val getpair: ?kind:pair_kind -> descr -> BoolPair.t
val pi1: t -> descr
val pi2: t -> descr
val pi2_restricted: descr -> t -> descr
......@@ -258,6 +259,8 @@ module Arrow : sig
val get: descr -> t
(* Always succeed; no check <= Arrow.any *)
val getpair: descr -> BoolPair.t
val domain: t -> descr
val apply: t -> descr -> descr
(* Always succeed; no check on the domain *)
......@@ -329,17 +332,37 @@ sig
val to_string: service_params -> string
end
module Witness: sig
module Witness : sig
type witness
val print_witness: Format.formatter -> witness -> unit
end
val witness: t -> Witness.witness
module Cache: sig
module Cache : sig
type 'a cache
val emp: 'a cache
val find: (t -> 'a) -> t -> 'a cache -> 'a cache * 'a
val memo: (t -> 'a) -> (t -> 'a)
end
module Tallying : sig
type constr = (bool * Custom.var * t)
module CS : sig
type key = (bool * Custom.var)
module M : Map.S with type key = key
module S : Set.S with type elt = t M.t
type cset = S.t
val merge : S.elt -> S.elt -> S.elt
val singleton : constr -> cset
val sat : cset
val unsat : cset
val cup : cset -> cset -> cset
val cap : cset -> cset -> cset
end
val norm : t -> CS.cset
end
......@@ -494,7 +494,7 @@ let deferr s = raise (Patterns.Error s)
mk_or q_empty x
let pcdata = star (PElem (mk_type (Types.char (Types.BoolChars.atom (`Atm (Chars.any))))))
let pcdata = star (PElem (mk_type (Types.char (Chars.any))))
let mix_regexp regexp =
let rec aux = function
| PSeq [] -> eps
......@@ -539,7 +539,7 @@ let deferr s = raise (Patterns.Error s)
let rec aux i =
if Encodings.Utf8.equal_index i j then Epsilon
else let (c,i) = Encodings.Utf8.next s i in
let t = Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_int c)))) in
let t = Types.char (Chars.atom (Chars.V.mk_int c)) in
Seq(Elem(mk_type t), aux i) in
aux (Encodings.Utf8.start_index s)
......
......@@ -318,7 +318,7 @@ module IType = struct
| Recurs (p,b) -> derecurs (fst (derecurs_def env b)) p
| Internal t -> mk_type t
| NsT ns ->
mk_type (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))))
mk_type (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))
| Or (p1,p2) -> mk_or (derecurs env p1) (derecurs env p2)
| And (p1,p2) -> mk_and (derecurs env p1) (derecurs env p2)
| Diff (p1,p2) -> mk_diff (derecurs env p1) (derecurs env p2)
......@@ -909,11 +909,11 @@ and type_check' loc env e constr precise = match e with
let t1 = Types.Arrow.get t1 in
let dom = Types.Arrow.domain t1 in
let res =
if Types.Arrow.need_arg t1 then
let t2 = type_check env e2 dom true in
Types.Arrow.apply t1 t2
else
(ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
if Types.Arrow.need_arg t1 then
let t2 = type_check env e2 dom true in
Types.Arrow.apply t1 t2
else
(ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
in
verify loc res constr
......@@ -931,9 +931,9 @@ and type_check' loc env e constr precise = match e with
| Dot (e,l) ->
let expect_rec = Types.record l (Types.cons constr) in
let expect_elt =
Types.xml
Types.any_node
(Types.cons (Types.times (Types.cons expect_rec) Types.any_node)) in
Types.xml
Types.any_node
(Types.cons (Types.times (Types.cons expect_rec) Types.any_node)) in
let t = type_check env e (Types.cup expect_rec expect_elt) precise in
let t_elt =
let t = Types.Product.pi2 (Types.Product.get ~kind:`XML t) in
......@@ -952,29 +952,29 @@ and type_check' loc env e constr precise = match e with
| Xtrans (e,b) ->
let t = type_check env e Sequence.any true in
let t =
try
Sequence.map_tree constr
(fun cstr t ->
let resid = Types.diff t b.br_accept in
let res = type_check_branches loc env t b cstr true in
(res,resid)
) t
with (Sequence.Error _) as exn ->
let rec find_loc = function
| Cduce_loc.Location (loc,precise,exn) ->
(loc,precise), exn
| Sequence.Error (Sequence.UnderTag (t,exn)) ->
let (l,exn) = find_loc exn in
l, Sequence.Error (Sequence.UnderTag (t,exn))
| exn -> raise Not_found
in
try
let (loc,precise), exn = find_loc exn in
raise (Cduce_loc.Location (loc,precise,exn))
with Not_found ->
raise_loc loc exn
in
verify loc t constr
try
Sequence.map_tree constr
(fun cstr t ->
let resid = Types.diff t b.br_accept in
let res = type_check_branches loc env t b cstr true in
(res,resid)
) t
with (Sequence.Error _) as exn ->
let rec find_loc = function
| Cduce_loc.Location (loc,precise,exn) ->
(loc,precise), exn
| Sequence.Error (Sequence.UnderTag (t,exn)) ->
let (l,exn) = find_loc exn in
l, Sequence.Error (Sequence.UnderTag (t,exn))
| exn -> raise Not_found
in
try
let (loc,precise), exn = find_loc exn in
raise (Cduce_loc.Location (loc,precise,exn))
with Not_found ->
raise_loc loc exn
in
verify loc t constr
| Validate (e, t, _) ->
ignore (type_check env e Types.any false);
......
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