Commit 08e8d89d authored by Julien Lopez's avatar Julien Lopez
Browse files

[TESTS][LAMBDA] Management of types improved

parent 6b40d01d
......@@ -31,5 +31,6 @@ type_id = [A-Z][A-Za-z0-9_]*
complex_type_id = [A-Z][A-Za-z0-9_]*
| complex_type_id * complex_type_id
| complex_type_id -> complex_type_id
| "(" complex_type_id ")"
integer = [0-9]+
......@@ -13,12 +13,21 @@ exception Error
(* TODO: We will need a much better representation of types and a much better
function when we'll add union types and polymorphism. *)
let is_subtype t1 t2 = if String.compare t1 t2 = 0 then true else false
let rec is_subtype arg1 arg2 = match arg1, arg2 with
| Type(t), Type(u) -> if String.compare t u = 0 then true else false
| TPair(t1, t2), TPair(u1, u2) -> (is_subtype t1 u1) && (is_subtype t2 u2)
| TArrow(t1, t2), TArrow(u1, u2) -> (is_subtype t1 u1) && (is_subtype t2 u2)
| _ -> false
let type_of_string s = match s with
| "Int" -> interval [Intervals.Any]
| _ -> Types.empty
let rec type_of_ptype arg = match arg with
| Type(t) -> type_of_string t
| TPair(t1, t2) -> times (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
| TArrow(t1, t2) -> arrow (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
let rec type_of_iface iface res = match iface with
| (ptype, rtype) :: rest -> type_of_iface rest
(cup (arrow (cons ptype) (cons rtype)) res)
......@@ -36,7 +45,7 @@ let rec _to_typed env l expr =
parse_abstr env l loc (Some(0, fun_name)) params rtype body
| Match (_, e, t, b) ->
let b = parse_branches env l t b [] in
let t = type_of_string t in
let t = type_of_ptype t in
let brs = { br_typ=t; br_accept=t; br_branches=b } in
let _, _, exp_descr = _to_typed env l e in
env, l, { exp_loc=loc; exp_typ=t;
......@@ -84,7 +93,7 @@ and parse_abstr env l loc fun_name params rtype body =
(* TODO: Fix exp_typ *)
env, l, { exp_loc=loc; exp_typ=any; exp_descr=Abstraction(abstr) }
in
_parse_abstr env l loc fun_name params (type_of_string rtype) body 0
_parse_abstr env l loc fun_name params (type_of_ptype rtype) body 0
and make_node fv =
let d = (match fv with
......@@ -95,15 +104,15 @@ and make_node fv =
and parse_iface env l params fv nb iface rtype = match params with
| (_, pname, ptype) :: [] -> true, env, (Locals.add pname nb l),
(fv @ [nb, pname]), (iface @ [type_of_string ptype, rtype]), []
(fv @ [nb, pname]), (iface @ [type_of_ptype ptype, rtype]), []
| (_, pname, ptype) :: rest -> false, env, (Locals.add pname nb l),
(fv @ [nb, pname]), (iface @ [itype rest (type_of_string ptype), rtype]),
(fv @ [nb, pname]), (iface @ [itype rest (type_of_ptype ptype), rtype]),
rest
| [] -> true, env, l, fv, iface, []
and itype iface res = match iface with
| (_, _, t) :: rest -> itype rest
(arrow (cons res) (cons (type_of_string t)))
(arrow (cons res) (cons (type_of_ptype t)))
| [] -> res
and parse_branches env l toptype brs res = match brs with
......@@ -133,9 +142,19 @@ and make_patterns t fv d = incr Patterns.counter;
Patterns.accept=(cons t); fv=fv }
and parse_match_value env l list p toptype = match p with
| MPair (_, m1, m2) ->
let t1, d1, list, l, b1 = parse_match_value env l list m1 toptype in
let t2, d2, list, l, b2 = parse_match_value env l list m2 toptype in
| MPair (loc, m1, m2) ->
let line = Loc.start_line loc in
let cbegin = Loc.start_off loc - Loc.start_bol loc in
let cend = Loc.stop_off loc - Loc.start_bol loc in
let fname = Loc.file_name loc in
let top1, top2 =
(match toptype with | TPair(t1, t2) -> t1, t2 | _ ->
Printf.eprintf "File %s, line %d, characters %d-%d:\nError:" fname
line cbegin cend;
Printf.eprintf " type %s is not a pair\n"
(Types.Print.to_string (type_of_ptype toptype)); raise Error) in
let t1, d1, list, l, b1 = parse_match_value env l list m1 top1 in
let t2, d2, list, l, b2 = parse_match_value env l list m2 top2 in
times (cons t1) (cons t2),
Patterns.Times (make_patterns t1 [] d1, make_patterns t2 [] d2),
list, l, b1 && b2;
......@@ -144,16 +163,16 @@ and parse_match_value env l list p toptype = match p with
let l = Locals.add mname lsize l in
let list = list @ [lsize, mname] in
let d1 = any, list, Patterns.Capture(lsize, mname) in
let t2 = type_of_string mtype in
let t2 = type_of_ptype mtype in
let d2 = t2, [], Patterns.Constr(t2) in
t2, Patterns.Cap(d1, d2), list, l, is_subtype toptype mtype
| MInt (_, i) ->
let t = constant (Integer(big_int_of_int i)) in
t, Patterns.Constr(t), list, l, is_subtype toptype "Int"
t, Patterns.Constr(t), list, l, is_subtype toptype (Type("Int"))
| MString (_, s) ->
let t = constant (String(0, String.length s - 1, s,
Integer(big_int_of_int 0))) in
t, Patterns.Constr(t), list, l, is_subtype toptype "String"
t, Patterns.Constr(t), list, l, is_subtype toptype (Type("String"))
let to_typed expr =
let env, l, expr = _to_typed empty_toplevel Locals.empty expr in
......
......@@ -149,7 +149,7 @@ in
try
let expr = ExprParser.of_string str file in
let env, texpr = Compute.to_typed expr in
eprintf "%s\n" (typed_to_string texpr); print_env env.Compile.vars;
(* eprintf "%s\n" (typed_to_string texpr); print_env env.Compile.vars;*)
let evalexpr = Compile.compile_eval_expr env texpr in
print_value evalexpr; printf "\n"
with
......
......@@ -17,7 +17,10 @@ and match_value =
| MVar of Loc.t * string * ptype
| MInt of Loc.t * int
| MString of Loc.t * string
and ptype = string
and ptype =
| Type of string
| TPair of ptype * ptype
| TArrow of ptype * ptype
module ExprParser = struct
......@@ -58,12 +61,13 @@ module ExprParser = struct
| "string" [ x = STRING -> MString(_loc, x) ]
];
type_id: [ "atom_type" [ t = UIDENT -> t ]
type_id: [ "atom_type" [ t = UIDENT -> Type(t) ]
| [ "("; t = complex_type_id; ")" -> t ]];
complex_type_id: [ "complex_type" LEFTA [ t = UIDENT -> t ]
| [ t1 = SELF; "*"; t2 = SELF -> t1 ^ "*" ^ t2
| t1 = SELF; "->"; t2 = SELF -> t1 ^ "->" ^ t2 ]];
complex_type_id: [ "complex_type" LEFTA [ t = UIDENT -> Type(t)
| "("; t = SELF; ")" -> t ]
| [ t1 = SELF; "*"; t2 = SELF -> TPair(t1, t2)
| t1 = SELF; "->"; t2 = SELF -> TArrow(t1, t2) ]];
END;;
......
......@@ -16,7 +16,10 @@ and match_value =
| MVar of Loc.t * string * ptype
| MInt of Loc.t * int
| MString of Loc.t * string
and ptype = string
and ptype =
| Type of string
| TPair of ptype * ptype
| TArrow of ptype * ptype
module ExprParser : sig
val of_string : string -> string -> expr
......
File ./tests/eval/tests/match_error_simple.test, line 1, characters 49-50:
Unbound identifier a
File ./tests/eval/tests/match_error_simple.test, line 1, characters 6-7:
Unbound identifier x
fun firsts x : (Int*Int) y : (Int*Int) : (Int*Int) -> match x,y : (Int*Int) with
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
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