Commit 2e68fa95 authored by Pietro Abate's avatar Pietro Abate
Browse files

fix polymorphic variabale "detection"

Now we correctly distibguish polymorphic and monomorphic types and
set sigma substitutions accordingly
parent 8c96ed41
......@@ -6,6 +6,7 @@ type env = {
vars: var_loc Env.t; (* Id.t to var_loc *)
sigma : sigma; (* symbolic substitutions (Lambda.sigma) *)
gamma : Types.Node.t IdMap.map; (* map of type variables to types *)
xi : Var.Set.t;
stack_size: int;
max_stack: int ref;
global_size: int
......@@ -18,6 +19,7 @@ let mk cu = {
vars = Env.empty;
sigma = Lambda.Identity;
gamma = IdMap.empty;
xi = Var.Set.empty;
stack_size = 0;
max_stack = ref 0;
global_size = 0
......@@ -59,7 +61,7 @@ let enter_global_cu cu env x =
global_size = env.global_size + 1 }
let rec domain = function
|Identity -> Var.Set.empty
|Identity -> assert false
|List l -> Types.Tallying.domain l
|Comp (s1,s2) -> Var.Set.union (domain s1) (domain s2)
|Sel(_,_,sigma) -> (domain sigma)
......@@ -107,13 +109,14 @@ and compile_aux env = function
| Typed.Var x -> Var (find x env)
| Typed.TVar x ->
let v = find x env in
let polyvars =
Var.Set.inter
(domain(env.sigma))
(Types.all_vars(Types.descr (IdMap.assoc x env.gamma)))
let ts = Types.all_vars (Types.descr (IdMap.assoc x env.gamma)) in
let is_mono () =
let d = Var.Set.inter env.xi (domain(env.sigma)) in
Var.Set.is_empty (Var.Set.inter ts d)
in
if Var.Set.is_empty polyvars then Var (v)
else TVar(v,env.sigma)
if Var.Set.is_empty ts then Var (v) else
if env.sigma = Identity then TVar(v,env.sigma) else
if is_mono () then Var (v) else TVar(v,env.sigma)
| Typed.Subst(e,sl) -> compile { env with sigma = comp env.sigma (List sl) } e
| Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
......@@ -161,23 +164,28 @@ and compile_abstr env a =
| Some x -> Env.add x (Env 0) Env.empty, [x, Types.cons a.Typed.fun_typ]
| None -> Env.empty, []
in
let polyvars =
let vs =
List.fold_left (fun acc (t1,t2) ->
let is_mono =
let vars =
List.fold_left(fun acc (t1,t2) ->
let ts1 = Types.all_vars t1 in
let ts2 = Types.all_vars t2 in
(Var.Set.union acc (Var.Set.union ts1 ts2))
let tu = Var.Set.union ts1 ts2 in
Var.Set.union acc tu
) Var.Set.empty a.Typed.fun_iface
in
Var.Set.inter (domain(env.sigma)) vs
if Var.Set.is_empty vars then true else
if env.sigma = Identity then false
else
let d = domain(env.sigma) in
Var.Set.is_empty (Var.Set.inter d vars)
in
let (slots,nb_slots,fun_env) =
(* we add a nameless empty slot for the argument *)
if not(Var.Set.is_empty polyvars) then
if is_mono then ([Dummy],1,fun_env)
else
let argvar = fresharg () in
([Dummy;Dummy],2,Env.add argvar (Env 1) fun_env)
else ([Dummy],1,fun_env)
in
let (slots,nb_slots,fun_env) =
......@@ -207,7 +215,7 @@ and compile_abstr env a =
in
let body = compile_branches env a.Typed.fun_body in
if Var.Set.is_empty polyvars then
if is_mono then
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack))
else
let sigma = Sel(Env 1,a.Typed.fun_iface,env.sigma) in
......@@ -232,7 +240,12 @@ and compile_branches env (brs : Typed.branches) =
and compile_branch env br =
let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
let m = Patterns.filter (Types.descr (Patterns.accept br.Typed.br_pat)) br.Typed.br_pat in
let env = { env with gamma = IdMap.union_disj m env.gamma } in
let env =
{ env with
gamma = IdMap.union_disj m env.gamma;
xi = Var.Set.union env.xi br.Typed.br_vars_poly
}
in
(br.Typed.br_pat, compile env br.Typed.br_body)
let enter_globals env n = match env.cu with
......
......@@ -25,7 +25,7 @@ type var_loc =
type iface = (Types.descr * Types.descr) list
type sigma =
| Identity
| Identity (* this is basically as Types.Tallying.CS.sat *)
| List of Types.Tallying.CS.sl
| Comp of (sigma * sigma)
| Sel of (var_loc * iface * sigma)
......
......@@ -11,7 +11,7 @@ let eval_op = Hashtbl.find ops
(* To write tail-recursive map-like iteration *)
let make_accu () = Value.Pair(nil,Absent,Value.Identity)
let make_accu () = Value.Pair(nil,Absent,Value.Mono)
let get_accu a = snd (Obj.magic a)
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
......@@ -88,6 +88,7 @@ let rec pp_sigma ppf =
|Value.Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
|Value.Sel(x,iface,s) -> Format.fprintf ppf "Sel(%d,%a,%a)" x pp_aux iface pp_sigma s
|Value.Identity -> Format.fprintf ppf "Id"
|Value.Mono -> Format.fprintf ppf "Mono"
and pp_value ppf = function
| Value.Pair(v1, v2, sigma) ->
......@@ -150,6 +151,8 @@ let apply_sigma sigma = function
let rec eval_sigma env locals = function
|Lambda.Comp(s1,s2) -> Value.Comp(eval_sigma env locals s1,eval_sigma env locals s2)
|Lambda.Identity -> Value.Identity
|Lambda.List [] -> Value.Mono
(* |Lambda.List i when i = Types.Tallying.CS.sat -> Value.Identity *)
|Lambda.List l -> Value.List l
|Lambda.Sel(x,iface,sigma) -> Value.Sel(1,iface,eval_sigma env locals sigma)
......@@ -173,26 +176,26 @@ let rec eval env locals = function
let sigma' = eval_sigma env locals sigma in
eval_abstraction env locals slots iface body lsize sigma'
| Abstraction (slots,iface,body,lsize) ->
eval_abstraction env locals slots iface body lsize Value.Identity
eval_abstraction env locals slots iface body lsize Value.Mono
| Const c -> c
| Pair (e1,e2) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
(* This is the empty substitution. sigma is associated to a pair only
* when is from a variable x_sigma *)
Value.Pair (v1,v2,Value.Identity)
Value.Pair (v1,v2,Value.Mono)
| Xml (e1,e2,e3) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
let v3 = eval env locals e3 in
Value.Xml (v1,v2,v3,Value.Identity)
Value.Xml (v1,v2,v3,Value.Mono)
| XmlNs (e1,e2,e3,ns) ->
let v1 = eval env locals e1 in
let v2 = eval env locals e2 in
let v3 = eval env locals e3 in
Value.XmlNs (v1,v2,v3,ns,Value.Identity)
Value.XmlNs (v1,v2,v3,ns,Value.Mono)
| Record r ->
Value.Record (Imap.map (eval env locals) r, Value.Identity)
Value.Record (Imap.map (eval env locals) r, Value.Mono)
| String (i,j,s,q) -> Value.substring_utf8 i j s (eval env locals q)
(* let is encoded as a match *)
| Match (e,brs) -> eval_branches env locals brs (eval env locals e)
......@@ -225,7 +228,7 @@ and eval_abstraction env locals slots iface body lsize sigma =
let env = Array.map (eval_var env locals) slots in
let f arg =
let v = eval_branches env (Array.create lsize Value.Absent) body arg in
if sigma <> Value.Identity then env.(1) <- arg;
if sigma <> Value.Mono then env.(1) <- arg;
pp_lambda_env Format.std_formatter env locals;
v
in
......
......@@ -193,18 +193,19 @@ let (@@) v sigma =
let rec eval_sigma env =
let open Value in function
|Identity -> []
|List l -> l
|Comp(s1,s2) -> (eval_sigma env s1) @ (eval_sigma env s2)
|Sel(x,iface,sigma) ->
List.fold_left (fun acc sigma_j ->
let exists_sub =
List.exists (fun (_,s_i) ->
inzero env env.(x) (Types.Tallying.(s_i @@ sigma_j))
) iface
in
if exists_sub then sigma_j::acc else acc
) [] (eval_sigma env sigma)
|Mono -> assert false
|Identity -> []
|List l -> l
|Comp(s1,s2) -> (eval_sigma env s1) @ (eval_sigma env s2)
|Sel(x,iface,sigma) ->
List.fold_left (fun acc sigma_j ->
let exists_sub =
List.exists (fun (_,s_i) ->
inzero env env.(x) (Types.Tallying.(s_i @@ sigma_j))
) iface
in
if exists_sub then sigma_j::acc else acc
) [] (eval_sigma env sigma)
and inzero env v t =
let open Value in
......
......@@ -7,6 +7,7 @@ type sigma =
| Comp of (sigma * sigma)
| Sel of (int * iface * sigma)
| Identity
| Mono
and t =
| Pair of t * t * sigma
......@@ -26,6 +27,8 @@ and t =
let rec comp s1 s2 = match s1, s2 with
| Identity, _ -> s2
| _, Identity -> s1
| Mono, _ -> s2
| _, Mono -> s1
(* If l1 subsigma of l2 or l2 subsigma of l1 then we keep the biggest *)
| List(l1), List(l2) -> (match Types.Tallying.subsigma l1 l2 with
| None -> Comp(s1, s2)
......@@ -72,7 +75,7 @@ let vbool x = if x then vtrue else vfalse
let vrecord l =
let l = List.map (fun (lab,v) -> Upool.int lab, v) l in
Record (Imap.create (Array.of_list l),Identity)
Record (Imap.create (Array.of_list l),Mono)
let get_fields = function
| Record (map,_) -> Obj.magic (Imap.elements map)
......@@ -80,24 +83,24 @@ let get_fields = function
let rec sequence = function
| [] -> nil
| h::t -> Pair (h, sequence t,Identity)
| h::t -> Pair (h, sequence t,Mono)
let rec sequence_rev accu = function
| [] -> accu
| h::t -> sequence_rev (Pair (h,accu,Identity)) t
| h::t -> sequence_rev (Pair (h,accu,Mono)) t
let sequence_rev l = sequence_rev nil l
let sequence_of_array a =
let rec aux accu i =
if (i = 0) then accu
else let i = pred i in aux (Pair (a.(i), accu,Identity)) i in
else let i = pred i in aux (Pair (a.(i), accu,Mono)) i in
aux nil (Array.length a)
let tuple_of_array a =
let rec aux accu i =
if (i = 0) then accu
else let i = pred i in aux (Pair (a.(i), accu,Identity)) i in
else let i = pred i in aux (Pair (a.(i), accu,Mono)) i in
let n = Array.length a in
aux a.(n) (pred n)
......@@ -107,7 +110,7 @@ let concat v1 v2 =
| (v1,v2) -> Concat (v1,v2)
let append v1 v2 =
concat v1 (Pair (v2,nil,Identity))
concat v1 (Pair (v2,nil,Mono))
let raise' v = raise (CDuceExn v)
let failwith' s = raise' (string_latin1 s)
......@@ -117,12 +120,12 @@ let rec const = function
| Types.Integer i -> Integer i
| Types.Atom a -> Atom a
| Types.Char c -> Char c
| Types.Pair (x,y) -> Pair (const x, const y,Identity)
| Types.Xml (x, Types.Pair (y, z)) -> Xml (const x, const y, const z,Identity)
| Types.Pair (x,y) -> Pair (const x, const y,Mono)
| Types.Xml (x, Types.Pair (y, z)) -> Xml (const x, const y, const z,Mono)
| Types.Xml (_,_) -> assert false
| Types.Record x ->
let x = LabelMap.mapi_to_list (fun l c -> (Upool.int l,const c)) x in
Record (Imap.create (Array.of_list x),Identity)
Record (Imap.create (Array.of_list x),Mono)
| Types.String (i,j,s,c) -> String_utf8 (i,j,s, const c)
let rec inv_const = function
......@@ -150,13 +153,13 @@ let rec inv_const = function
let normalize_string_latin1 i j s q =
if i = j then q else
Pair (Char (Chars.V.mk_char (String.unsafe_get s i)), String_latin1 (succ i,j,s,q),Identity)
Pair (Char (Chars.V.mk_char (String.unsafe_get s i)), String_latin1 (succ i,j,s,q),Mono)
let normalize_string_utf8 i j s q =
if Utf8.equal_index i j then q
else
let (c,i) = Utf8.next s i in
Pair (Char (Chars.V.mk_int c), String_utf8 (i,j,s,q),Identity)
Pair (Char (Chars.V.mk_int c), String_utf8 (i,j,s,q),Mono)
......@@ -200,7 +203,7 @@ let rec flatten = function
| q -> q
let eval_lazy_concat v =
let accu = Obj.magic (Pair (nil,Absent,Identity)) in
let accu = Obj.magic (Pair (nil,Absent,Mono)) in
let rec aux accu = function
| Concat (x,y) -> aux (append_cdr accu x) y
| v -> set_cdr accu v
......@@ -312,6 +315,7 @@ let rec pp_sigma ppf =
|Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
|Sel(x,iface,s) -> Format.fprintf ppf "Sel(%d,%a,%a)" x pp_aux iface pp_sigma s
|Identity -> Format.fprintf ppf "Id"
|Mono -> Format.fprintf ppf "Mono"
let rec print ppf v =
if is_str v then
......@@ -600,9 +604,9 @@ let map_xml map_pcdata map_other =
let tagged_tuple tag vl =
let ct = sequence vl in
let at = Record (Imap.empty,Identity) in
let at = Record (Imap.empty,Mono) in
let tag = Atom (Atoms.V.mk_ascii tag) in
Xml (tag, at, ct,Identity)
Xml (tag, at, ct,Mono)
(** set of values *)
......@@ -675,7 +679,7 @@ let label_ascii s =
Label.mk_ascii s
let record (l : (label * t) list) =
Record (Imap.create (Array.of_list (Obj.magic l)),Identity)
Record (Imap.create (Array.of_list (Obj.magic l)),Mono)
let record_ascii l =
record (List.map (fun (l,v) -> (label_ascii l, v)) l)
......@@ -702,20 +706,20 @@ let mk_rf ~get ~set =
let mk_ref t v =
let r = ref v in
let get = Abstraction (Some [Sequence.nil_type, t], (fun _ -> !r),Identity)
and set = Abstraction (Some [t, Sequence.nil_type], (fun x -> r := x; nil),Identity) in
Record (mk_rf ~get ~set,Identity)
let get = Abstraction (Some [Sequence.nil_type, t], (fun _ -> !r),Mono)
and set = Abstraction (Some [t, Sequence.nil_type], (fun x -> r := x; nil),Mono) in
Record (mk_rf ~get ~set,Mono)
let mk_ext_ref t get set =
let get = Abstraction (
(match t with Some t -> Some [Sequence.nil_type, t] | None -> None),
(fun _ -> get ()),Identity)
(fun _ -> get ()),Mono)
and set = Abstraction (
(match t with Some t -> Some [t, Sequence.nil_type] | None -> None),
(fun v -> set v; nil),Identity)
(fun v -> set v; nil),Mono)
in
Record (mk_rf ~get ~set,Identity)
Record (mk_rf ~get ~set,Mono)
let ocaml2cduce_int i =
Integer (Intervals.V.from_int i)
......@@ -784,18 +788,18 @@ let cduce2ocaml_option f v =
let ocaml2cduce_option f = function
| Some x -> Pair (f x, nil,Identity)
| Some x -> Pair (f x, nil,Mono)
| None -> nil
let add v1 v2 = match (v1,v2) with
| (Integer x, Integer y) -> Integer (Intervals.V.add x y)
| (Record (r1,sigma1), Record (r2,sigma2)) -> Record (Imap.merge r1 r2,Identity) (* XXX *)
| (Record (r1,sigma1), Record (r2,sigma2)) -> Record (Imap.merge r1 r2,Mono) (* XXX *)
| _ -> assert false
let merge v1 v2 = match (v1,v2) with
| (Record (r1,sigma1), Record (r2,sigma2)) -> Record (Imap.merge r1 r2,Identity) (* XXX *)
| (Record (r1,sigma1), Record (r2,sigma2)) -> Record (Imap.merge r1 r2,Mono) (* XXX *)
| _ -> assert false
let sub v1 v2 = match (v1,v2) with
......@@ -815,8 +819,8 @@ let modulo v1 v2 = match (v1,v2) with
| _ -> assert false
let pair v1 v2 = Pair (v1,v2,Identity)
let xml v1 v2 v3 = Xml (v1,v2,v3,Identity)
let pair v1 v2 = Pair (v1,v2,Mono)
let xml v1 v2 v3 = Xml (v1,v2,v3,Mono)
let mk_record labels fields =
let l = ref [] in
......@@ -867,7 +871,7 @@ let remove_field l = function
let rec ocaml2cduce_list f = function
| [] -> nil
| hd::tl -> Pair (f hd, ocaml2cduce_list f tl,Identity)
| hd::tl -> Pair (f hd, ocaml2cduce_list f tl,Mono)
let rec cduce2ocaml_list f v =
match normalize v with
......@@ -877,10 +881,10 @@ let rec cduce2ocaml_list f v =
let ocaml2cduce_array f x = ocaml2cduce_list f (Array.to_list x)
let cduce2ocaml_array f x = Array.of_list (cduce2ocaml_list f x)
let no_attr = Record (Imap.empty,Identity)
let no_attr = Record (Imap.empty,Mono)
let ocaml2cduce_constr tag va =
Xml (tag, no_attr, sequence_of_array va,Identity)
Xml (tag, no_attr, sequence_of_array va,Mono)
let rec cduce2ocaml_constr m = function
| Atom q ->
......@@ -903,7 +907,7 @@ let rec cduce2ocaml_variant m = function
let ocaml2cduce_fun farg fres f =
Abstraction (None, (fun x -> fres (f (farg x))),Identity)
Abstraction (None, (fun x -> fres (f (farg x))),Mono)
let cduce2ocaml_fun farg fres = function
| Abstraction (_,f,_) -> (fun x -> fres (f (farg x)))
......
......@@ -7,6 +7,7 @@ type sigma =
| Comp of (sigma * sigma)
| Sel of (int * iface * sigma)
| Identity
| Mono
and t =
(* Canonical representation *)
......
......@@ -86,8 +86,13 @@ let run_test_eval str =
try
let expr = Parse.ExprParser.of_string_no_file str in
let env, texpr = Compute.to_typed expr in
let evalexpr = Compile.compile_eval_expr env texpr in
Printer.value_to_string evalexpr
let lambdaexpr,lsize = Compile.compile_expr env texpr in
Format.printf "Input : %s\n" str;
Format.printf "Lambda : %s\n" (Printer.lambda_to_string lambdaexpr);
let evalexpr = Eval.expr lambdaexpr lsize in
let v = Printer.value_to_string evalexpr in
Format.printf "Eval : %s\n\n" v;
v
with
| Compute.Error -> exit 3
| Loc.Exc_located (loc, exn) ->
......@@ -104,6 +109,7 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
assert_equal ~msg:"Test CDuce.runtime.abstr.let_simple failed"
~printer:(fun x -> x) "3"
(run_test_eval "let x : Int = 3 in x : Int");
assert_equal ~msg:"Test CDuce.runtime.abstr.let_medium failed"
~printer:(fun x -> x) "2"
(run_test_eval "let f : (Int -> Int) = (fun (Int -> Int) | x : Int -> x)
......@@ -119,11 +125,11 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
in (let x : Int = f.2
in f.x : Int) : Int");
assert_equal ~msg:"Test CDuce.runtime.abstr.simple failed"
~printer:(fun x -> x) "Abstraction((Int,Int),Id)"
~printer:(fun x -> x) "Abstraction((Int,Int),Mono)"
(run_test_eval "fun f x : Int : Int -> 2");
assert_equal ~msg:"Test CDuce.runtime.abstr.medium failed"
~printer:(fun x -> x)
"Abstraction((Int,[ Char* ] -> [ Int Char* ]),Id)"
"Abstraction((Int,[ Char* ] -> [ Int Char* ]),Mono)"
(run_test_eval "fun f x : Int y : String : (Int*String) -> x,y");
);
......@@ -132,17 +138,17 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
~printer:(fun x -> x) "2"
(run_test_eval "(fun f x : Int : Int -> x).2");
assert_equal ~msg:"Test CDuce.runtime.apply.simple_pair failed"
~printer:(fun x -> x) "(3,2,Id)"
~printer:(fun x -> x) "(3,2,Mono)"
(run_test_eval "(fun f x : (Int*Int) : (Int*Int) -> x).(3,2)");
assert_equal ~msg:"Test CDuce.runtime.apply.medium failed"
~printer:(fun x -> x) "(2,3,Id)"
~printer:(fun x -> x) "(2,3,Mono)"
(run_test_eval "((fun f x : Int y : Int : (Int*Int) -> x,y).2).3");
);
"misc" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.runtime.misc.even failed"
~printer:(fun x -> x)
"Abstraction((Int,Bool),(Any \\ (Int),Any \\ (Int)),Id)"
"Abstraction((Int,Bool),(Any \\ (Int),Any \\ (Int)),Mono)"
(run_test_eval "fun ((Int -> Bool) & ((!Int) -> (!Int)))
| x : Int -> (match (x % 2) : Int with
| 0 -> `true
......@@ -166,7 +172,7 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
| x : (!Int) -> x).8");
assert_equal ~msg:"Test CDuce.runtime.misc.even_applied3 failed"
~printer:(fun x -> x)
"(2,(3,Atom(nil),Id),Id)"
"(2,(3,Atom(nil),Mono),Mono)"
(run_test_eval "(fun ((Int -> Bool) & ((!Int) -> (!Int)))
| x : Int -> (match (x % 2) : Int with
| 0 -> `true
......@@ -174,7 +180,7 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
| x : (!Int) -> x).[2; 3]");
assert_equal ~msg:"Test CDuce.runtime.misc.is_int failed"
~printer:(fun x -> x)
"Abstraction((Int,Bool),(Bool,Bool),(Any \\ (Int | Bool),Any \\ (Int | Bool)),Id)"
"Abstraction((Int,Bool),(Bool,Bool),(Any \\ (Int | Bool),Any \\ (Int | Bool)),Mono)"
(run_test_eval "fun ((Int -> Bool) & (Bool -> Bool) & ((!(Int|Bool)) -> (!(Int|Bool))))
| x : Int -> `true
| x : Bool -> `false
......@@ -195,21 +201,23 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
| x : (!(Int|Bool)) -> x).`true");
assert_equal ~msg:"Test CDuce.runtime.misc.is_int_applied3 failed"
~printer:(fun x -> x)
"(2,(3,Atom(nil),Id),Id)"
"(2,(3,Atom(nil),Mono),Mono)"
(run_test_eval "(fun ((Int -> Bool) & (Bool -> Bool) & ((!(Int|Bool)) -> (!(Int|Bool))))
| x : Int -> `true
| x : Bool -> `false
| x : (!(Int|Bool)) -> x).[2; 3]");
assert_equal ~msg:"Test CDuce.runtime.misc.map failed"
~printer:(fun x -> x)
"Abstraction((`$A -> `$B,[ `$A* ] -> [ `$B* ]),Id)"
"Abstraction((`$A -> `$B,[ `$A* ] -> [ `$B* ]),Sel(1,(`$A -> `$B -> [ `$A* ] ->
[
`$B* ]),Id))"
(run_test_eval "fun map f : ('A -> 'B) x : ['A] : ['B] ->
match x : ['A] with
| (el : 'A) :: [] -> f.el
| (el : 'A) :: (rest : ['A]) -> ((f.el), ((map.f).rest))");
assert_equal ~msg:"Test CDuce.runtime.misc.map_even_simple failed"
~printer:(fun x -> x)
"(\"hey\",(Atom(false),Atom(nil),Id),Id)"
"(\"hey\",(Atom(false),Atom(nil),Mono),Mono)"
(run_test_eval "(fun map f : ('A->'B) x : ['A] : ['B] ->
match x : ['A] with
| (el : 'A) :: (rest : ['A]) -> ((f.el), ((map.f).rest))
......@@ -220,7 +228,7 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
| x : (!Int) -> x).[\"hey\"; 3]");
assert_equal ~msg:"Test CDuce.runtime.misc.map_even_medium failed"
~printer:(fun x -> x)
"(Atom(true),(\"hey\",(Atom(false),(Atom(true),Atom(nil),Id),Id),Id),Id)"
"(Atom(true),(\"hey\",(Atom(false),(Atom(true),Atom(nil),Mono),Mono),Mono),Mono)"
(run_test_eval "(fun map f : ('A->'B) x : ['A] : ['B] ->
match x : ['A] with
| (el : 'A) :: (rest : ['A]) -> ((f.el), ((map.f).rest))
......@@ -264,18 +272,18 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
| x : (!(Int|Bool)) -> x).[`true; 3; `true]");
assert_equal ~msg:"Test CDuce.runtime.misc.firsts failed"
~printer:(fun x -> x)
"Abstraction(((Int,Int),X1 -> X1 where X1 = (Int,Int)),Id)"
"Abstraction(((Int,Int),X1 -> X1 where X1 = (Int,Int)),Mono)"
(run_test_eval "fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) ->
match x,y : ((Int*Int)*(Int*Int)) with
| (a : Int,_ : Int),(b : Int,_ : Int) -> a,b");
assert_equal ~msg:"Test CDuce.runtime.misc.firsts_applied failed"
~printer:(fun x -> x) "(5,1,Id)"
~printer:(fun x -> x) "(5,1,Mono)"
(run_test_eval "((fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) ->
match x,y : ((Int*Int)*(Int*Int)) with
| (a : Int,_ : Int),(b : Int,_ : Int) -> a,b)
.(5, 3)).(1, 4)");
assert_equal ~msg:"Test CDuce.runtime.misc.applier failed"
~printer:(fun x -> x) "Abstraction((Int,Int -> Int -> Int),Id)"
~printer:(fun x -> x) "Abstraction((Int,Int -> Int -> Int),Mono)"
(run_test_eval "fun applier x : Int f : (Int->Int) : Int -> f.x");
assert_equal ~msg:"Test CDuce.runtime.misc.applier_applied failed"
~printer:(fun x -> x) "2"
......@@ -332,11 +340,11 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
| (el : Int) :: (_ : [Int]) -> el
| [] -> 3");
assert_equal ~msg:"Test CDuce.runtime.list.tail failed"
~printer:(fun x -> x) "Abstraction(([ Int* ],[ Int* ]),Id)"
~printer:(fun x -> x) "Abstraction(([ Int* ],[ Int* ]),Mono)"
(run_test_eval "fun tail x : [Int] : [Int] -> match x : [Int] with
| (_ : Int) :: (rest : [Int]) -> rest");
assert_equal ~msg:"Test CDuce.runtime.list.tail.eval failed"
~printer:(fun x -> x) "(2,(5,Atom(nil),Id),Id)"
~printer:(fun x -> x) "(2,(5,Atom(nil),Mono),Mono)"
(run_test_eval "(fun tail x : [Int] : [Int] -> match x : [Int] with
| (_ : Int) :: (rest : [Int]) -> rest).[1; 2; 5]");
assert_equal ~msg:"Test CDuce.runtime.list.last failed"
......@@ -345,12 +353,12 @@ let tests_eval = "CDuce runtime tests (Typed -> Lambda -> Value)" >:::
| (el : Int) :: [] -> el
| (_ : Int) :: (rest : [Int]) -> f.rest).[1; 2; 5; 4; 8; 7]");
assert_equal ~msg:"Test CDuce.runtime.list.plusone failed"
~printer:(fun x -> x) "(2,(3,(6,(5,(9,8,Id),Id),Id),Id),Id)"