Make sure to run check_type on every
Types declared by the user must be checked (this will also replaced names with the correct longname).
This commit is contained in:
parent
03b792a220
commit
3bf2d82d45
|
@ -21,12 +21,12 @@ module Type =
|
||||||
struct
|
struct
|
||||||
let sigtype { sig_name = name; sig_inputs = i_list; sig_statefull = statefull;
|
let sigtype { sig_name = name; sig_inputs = i_list; sig_statefull = statefull;
|
||||||
sig_outputs = o_list; sig_params = params } =
|
sig_outputs = o_list; sig_params = params } =
|
||||||
let const_env = build_node_params NamesEnv.empty params in
|
let typed_params, const_env = build_node_params NamesEnv.empty params in
|
||||||
let check_arg a = { a with a_type = check_type const_env a.a_type } in
|
let check_arg a = { a with a_type = check_type const_env a.a_type } in
|
||||||
name, { node_inputs = List.map check_arg i_list;
|
name, { node_inputs = List.map check_arg i_list;
|
||||||
node_outputs = List.map check_arg o_list;
|
node_outputs = List.map check_arg o_list;
|
||||||
node_statefull = statefull;
|
node_statefull = statefull;
|
||||||
node_params = params;
|
node_params = typed_params;
|
||||||
node_params_constraints = []; }
|
node_params_constraints = []; }
|
||||||
|
|
||||||
let read { interf_desc = desc; interf_loc = loc } =
|
let read { interf_desc = desc; interf_loc = loc } =
|
||||||
|
|
|
@ -549,7 +549,7 @@ and expect_static_exp const_env exp_ty se =
|
||||||
try
|
try
|
||||||
unify ty exp_ty; se
|
unify ty exp_ty; se
|
||||||
with
|
with
|
||||||
Unify -> message se.se_loc (Etype_clash(ty, exp_ty))
|
_ -> message se.se_loc (Etype_clash(ty, exp_ty))
|
||||||
|
|
||||||
(** @return the type of the field with name [f] in the list
|
(** @return the type of the field with name [f] in the list
|
||||||
[fields]. [t1] is the corresponding record type and [loc] is
|
[fields]. [t1] is the corresponding record type and [loc] is
|
||||||
|
@ -1078,8 +1078,11 @@ let solve loc cl =
|
||||||
Solve_failed c -> message loc (Econstraint_solve_failed c)
|
Solve_failed c -> message loc (Econstraint_solve_failed c)
|
||||||
|
|
||||||
let build_node_params const_env l =
|
let build_node_params const_env l =
|
||||||
List.fold_left (fun env p -> NamesEnv.add p.p_name p.p_type env)
|
let check_param env p =
|
||||||
const_env l
|
let ty = check_type const_env p.p_type in
|
||||||
|
{ p with p_type = ty }, NamesEnv.add p.p_name ty env
|
||||||
|
in
|
||||||
|
mapfold check_param const_env l
|
||||||
|
|
||||||
let node ({ n_name = f; n_statefull = statefull;
|
let node ({ n_name = f; n_statefull = statefull;
|
||||||
n_input = i_list; n_output = o_list;
|
n_input = i_list; n_output = o_list;
|
||||||
|
@ -1087,9 +1090,10 @@ let node ({ n_name = f; n_statefull = statefull;
|
||||||
n_local = l_list; n_equs = eq_list; n_loc = loc;
|
n_local = l_list; n_equs = eq_list; n_loc = loc;
|
||||||
n_params = node_params; } as n) =
|
n_params = node_params; } as n) =
|
||||||
try
|
try
|
||||||
let const_env = build_node_params NamesEnv.empty node_params in
|
let typed_params, const_env =
|
||||||
|
build_node_params NamesEnv.empty node_params in
|
||||||
let typed_i_list, input_names, h = build const_env Env.empty Env.empty i_list in
|
let typed_i_list, input_names, h =
|
||||||
|
build const_env Env.empty Env.empty i_list in
|
||||||
let typed_o_list, output_names, h = build const_env h h o_list in
|
let typed_o_list, output_names, h = build const_env h h o_list in
|
||||||
|
|
||||||
(* typing contract *)
|
(* typing contract *)
|
||||||
|
@ -1107,12 +1111,13 @@ let node ({ n_name = f; n_statefull = statefull;
|
||||||
|
|
||||||
let cl = get_size_constraint () in
|
let cl = get_size_constraint () in
|
||||||
let cl = solve loc cl in
|
let cl = solve loc cl in
|
||||||
add_value f (signature statefull i_list o_list node_params cl);
|
add_value f (signature statefull typed_i_list typed_o_list typed_params cl);
|
||||||
|
|
||||||
{ n with
|
{ n with
|
||||||
n_input = List.rev typed_i_list;
|
n_input = List.rev typed_i_list;
|
||||||
n_output = List.rev typed_o_list;
|
n_output = List.rev typed_o_list;
|
||||||
n_local = typed_l_list;
|
n_local = typed_l_list;
|
||||||
|
n_params = typed_params;
|
||||||
n_contract = typed_contract;
|
n_contract = typed_contract;
|
||||||
n_equs = typed_eq_list }
|
n_equs = typed_eq_list }
|
||||||
with
|
with
|
||||||
|
@ -1140,8 +1145,9 @@ let deftype { t_name = n; t_desc = tdesc; t_loc = loc } =
|
||||||
TypingError(error) -> message loc error
|
TypingError(error) -> message loc error
|
||||||
|
|
||||||
let typing_const_dec cd =
|
let typing_const_dec cd =
|
||||||
let se = expect_static_exp NamesEnv.empty cd.c_type cd.c_value in
|
let ty = check_type NamesEnv.empty cd.c_type in
|
||||||
let cd = { cd with c_value = se } in
|
let se = expect_static_exp NamesEnv.empty ty cd.c_value in
|
||||||
|
let cd = { cd with c_value = se; c_type = ty } in
|
||||||
add_const cd.c_name (mk_const_def cd.c_name cd.c_type cd.c_value);
|
add_const cd.c_name (mk_const_def cd.c_name cd.c_type cd.c_value);
|
||||||
cd
|
cd
|
||||||
|
|
||||||
|
|
|
@ -176,7 +176,8 @@ let mk_call ?(params=[]) op exps =
|
||||||
Eapp (mk_app op params, exps)
|
Eapp (mk_app op params, exps)
|
||||||
|
|
||||||
let mk_op_call ?(params=[]) s exps =
|
let mk_op_call ?(params=[]) s exps =
|
||||||
mk_call ~params:params (Efun (Name s)) exps
|
mk_call ~params:params
|
||||||
|
(Efun (Modname { qual = "Pervasives"; id = s })) exps
|
||||||
|
|
||||||
let mk_iterator_call it ln params n exps =
|
let mk_iterator_call it ln params n exps =
|
||||||
Eiterator (it, mk_app (Enode ln) params, n, exps)
|
Eiterator (it, mk_app (Enode ln) params, n, exps)
|
||||||
|
|
|
@ -102,7 +102,7 @@ let translate_iterator_type = function
|
||||||
|
|
||||||
let op_from_app loc app =
|
let op_from_app loc app =
|
||||||
match app.a_op with
|
match app.a_op with
|
||||||
| Efun op -> op_from_app_name op
|
| Efun op | Enode op -> op_from_app_name op
|
||||||
| _ -> raise Not_static
|
| _ -> raise Not_static
|
||||||
|
|
||||||
let rec static_exp_of_exp const_env e =
|
let rec static_exp_of_exp const_env e =
|
||||||
|
|
Loading…
Reference in a new issue