Commit a0aab89f authored by Julien Lopez's avatar Julien Lopez
Browse files

[TESTS][LAMBDA] Solve runtime errors

parent 6d582266
......@@ -31,9 +31,9 @@ let rec _to_typed env l expr =
env, l, { exp_loc=loc;
exp_typ=(Types.Arrow.apply (Types.Arrow.get e1.exp_typ) e2.exp_typ);
exp_descr=Apply(e1, e2) }
| Abstr (origloc, fun_name, iface, body) ->
| Abstr (origloc, fun_name, iface, fv, body) ->
let fname = match fun_name with | "_" -> None | _ -> Some(0, fun_name) in
parse_abstr env l origloc fname iface body
parse_abstr env l origloc fname iface fv body
| Match (_, e, t, b) ->
let b, btype = parse_branches env l t [] Types.empty b in
let t = type_of_ptype t in
......@@ -140,16 +140,17 @@ and first_param loc iface =
in
_first_param loc [] iface
and parse_abstr env l loc fun_name iface body =
and parse_abstr env l loc fun_name iface fv body =
let fun_typ = type_of_ptype iface in
let ptype, iface = first_param loc iface in
let l = (match fun_name with
| None -> l
| Some (id, name) -> Locals.add name (id,fun_typ) l) in
let b, btype = parse_branches env l ptype [] Types.empty body in
let brs = { Typed.br_typ=btype; br_accept=Types.any; br_branches=b } in
let brs = { Typed.br_typ=type_of_ptype ptype; br_accept=Types.any;
br_branches=b } in
let abstr = { Typed.fun_name=fun_name; fun_iface=iface; fun_body=brs;
fun_typ=fun_typ; fun_fv=[] } in
fun_typ=fun_typ; fun_fv=fv } in
env, l, { Typed.exp_loc=caml_loc_to_cduce loc; exp_typ=fun_typ;
exp_descr=Typed.Abstraction(abstr) }
......
......@@ -4,7 +4,7 @@ open Camlp4.PreCast
type expr =
| Subst of Loc.t * expr * (string * ptype) list
| Apply of Loc.t * expr * expr
| Abstr of Loc.t * fun_name * ptype * branches
| Abstr of Loc.t * fun_name * ptype * fv * branches
| Match of Loc.t * expr * ptype * branches
| Pair of Loc.t * expr * expr
| Var of Loc.t * string
......@@ -12,6 +12,7 @@ type expr =
| String of Loc.t * string
| Bool of Loc.t * string
and fun_name = string
and fv = (int * string) list
and branches = (Loc.t * match_value * expr) list
and match_value =
| MPair of Loc.t * match_value * match_value
......@@ -41,18 +42,22 @@ module ExprParser = struct
[
"abstr" RIGHTA
[ "fun"; x = LIDENT; p = LIST1 param; ":"; t = type_id; "->"; e = SELF ->
let rec aux acc t = function
let rec make_fv accu nb = function
| _ :: [] | [] -> accu
| (_, name, _) :: rest -> make_fv (accu @ [nb, name]) (nb+1) rest in
let rec aux acc t fv = function
| (loc, pname, ptype) :: [] ->
let t = TArrow(ptype, t) in
Abstr(_loc, x, t, [_loc, MVar(loc, pname, ptype), acc])
Abstr(_loc, x, t, [], [_loc, MVar(loc, pname, ptype), acc])
| (loc, pname, ptype) :: rest ->
let t = TArrow(ptype, t) in
aux (Abstr(_loc, "_", t, [_loc, MVar(loc, pname, ptype), acc]))
t rest
let newfv = match fv with | _ :: rest -> rest | [] -> assert false in
aux (Abstr(_loc, "_", t, fv, [_loc, MVar(loc, pname, ptype), acc]))
t newfv rest
| [] -> acc
in
aux e t p
| "fun"; t = type_id; b = LIST1 branch -> Abstr(_loc, "_", t, b)
aux e t (make_fv [] 1 p) (List.rev p)
| "fun"; t = type_id; b = LIST1 branch -> Abstr(_loc, "_", t, [], b)
| "match"; e = SELF; ":"; t = type_id; "with"; b = LIST1 branch ->
Match(_loc, e, t, b) ]
| "pair" LEFTA
......@@ -114,7 +119,7 @@ end
let get_loc expr = match expr with
| Subst (loc, _, _) -> loc
| Apply (loc, _, _) -> loc
| Abstr (loc, _, _, _) -> loc
| Abstr (loc, _, _, _, _) -> loc
| Match (loc, _, _, _) -> loc
| Pair (loc, _, _) -> loc
| Var (loc, _) -> loc
......
......@@ -3,7 +3,7 @@ open Camlp4.PreCast
type expr =
| Subst of Loc.t * expr * (string * ptype) list
| Apply of Loc.t * expr * expr
| Abstr of Loc.t * fun_name * ptype * branches
| Abstr of Loc.t * fun_name * ptype * fv * branches
| Match of Loc.t * expr * ptype * branches
| Pair of Loc.t * expr * expr
| Var of Loc.t * string
......@@ -11,6 +11,7 @@ type expr =
| String of Loc.t * string
| Bool of Loc.t * string
and fun_name = string
and fv = (int * string) list
and branches = (Loc.t * match_value * expr) list
and match_value =
| MPair of Loc.t * match_value * match_value
......
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