let rec check_block block block_ctx rettype =
let typing_error has_t used_with_t pos =
raise (Parse_error("typing error (expression has type " ^ (string_of_type has_t) ^ " but is used with type " ^ (string_of_type used_with_t) ^ ")", pos))
in
let undefined_variable_error v =
raise (Parse_error("variable " ^ v.var_name ^ " is used without having been declared", v.var_pos))
in
let rec get_def_ctx ctx name =
match ctx with
| c :: s ->
(
try
get_def c name
with
| Not_found -> get_def_ctx s name
)
| [] -> raise Not_found
in
let get_var_def ctx v =
match v.var_def with
| Some d -> d
| None ->
try
let d = get_def_ctx ctx v.var_name in
v.var_def <- Some d; d
with
| Not_found -> undefined_variable_error v
in
let get_def_value ctx name =
(get_def_ctx ctx name).def_value
in
let get_var_value ctx v =
(get_var_def ctx v).def_value
in
let rec get_var_type ctx v =
if v.var_type = Unknown_type then
v.var_type <- (get_var_def ctx v).def_type;
v.var_type
and get_var_nature ctx v =
if v.var_nature = Unknown_nature then
v.var_nature <- (get_var_def ctx v).def_nature;
v.var_nature
and is_constant = function
| Cst -> true
| _ -> false
and get_expr_nature ctx e =
let is_a_constant v =
match (get_var_def ctx v).def_value with
| Constant _ -> true
| _ -> false
in
let score_of_nature = function
| Cst -> 0
| Varb -> 1
| Funct -> 2
| Unknown_nature -> failwith "trying to get the nature of a not yet typed expression"
in
let nature_of_score = function
| 0 -> Cst
| 1 -> Varb
| 2 -> Funct
| _ -> failwith "internal error"
in
match e.expr_val with
| Lt(e1, e2)
| Le(e1, e2)
| Eq(e1, e2)
| Neq(e1, e2)
| Plus(e1, e2)
| Minus(e1, e2)
| Mult(e1, e2)
| Div(e1, e2)
| Mod(e1, e2)
| And(e1, e2)
| Or(e1, e2) ->
nature_of_score (max (score_of_nature (get_expr_nature ctx e1)) (score_of_nature (get_expr_nature ctx e2)))
| Uminus e
| Not e -> get_expr_nature ctx e
| Int _
| Bool _ -> Cst
| Var(v, []) when is_a_constant v -> Cst
| Var(v, _) -> Varb
| New _
| Bang _
| Address_of _
| Rec _
| Arr _ -> Varb
and resolve_user_type ctx t =
let get_user_type_def tn =
try
match get_def_value ctx tn with
| Type t -> t
| _ -> raise (Parse_error(tn ^ " is not an user type", (-1, -1)))
with
| Not_found ->
raise (Parse_error("user type " ^ tn ^ " is used without having been declared", (-1, -1)))
in
match t with
| User_type tn -> get_user_type_def tn
| Array(t, i, f) -> Array(resolve_user_type ctx t, i, f)
| Record l -> Record((List.map (fun (n, t) -> n, resolve_user_type ctx t)) l)
| Pointer t -> Pointer (resolve_user_type ctx t)
| _ -> t
and get_expr_type ctx e =
if e.expr_type = Unknown_type then
e.expr_type <- resolve_user_type ctx
(
match e.expr_val with
| Lt(e1, e2)
| Le(e1, e2) ->
let te1 = get_expr_type ctx e1 in
let te2 = get_expr_type ctx e2 in
if te1 <> Integer then
typing_error te1 Integer e1.expr_pos
else if te2 <> Integer then
typing_error te2 Integer e2.expr_pos
else Boolean
| Eq(e1, e2)
| Neq(e1, e2) ->
let te1 = get_expr_type ctx e1 in
let te2 = get_expr_type ctx e2 in
if te1 <> Integer && te1 <> Boolean then
typing_error te1 te2 e1.expr_pos;
if te1 <> te2 then
typing_error te1 te2 e1.expr_pos;
Boolean
| Plus(e1, e2)
| Minus(e1, e2)
| Mult(e1, e2)
| Div(e1, e2)
| Mod(e1, e2) ->
let te1 = get_expr_type ctx e1 in
let te2 = get_expr_type ctx e2 in
if te1 <> Integer then
typing_error te1 Integer e1.expr_pos
else if te2 <> Integer then
typing_error te2 Integer e2.expr_pos
else Integer
| Uminus e ->
let te = get_expr_type ctx e in
if te <> Integer then
typing_error te Integer e.expr_pos
else Integer
| And(e1, e2)
| Or(e1, e2) ->
let te1 = get_expr_type ctx e1 in
let te2 = get_expr_type ctx e2 in
if te1 <> Boolean then
typing_error te1 Boolean e1.expr_pos
else if te2 <> Boolean then
typing_error te2 Boolean e2.expr_pos
else Boolean
| Not e ->
let te = get_expr_type ctx e in
if te <> Boolean then
typing_error te Boolean e.expr_pos
else Boolean
| Int _ -> Integer
| Bool _ -> Boolean
| Arr(e1, e2) ->
if get_expr_type ctx e2 <> Integer then
raise (Parse_error("typing error (integer expected)", e2.expr_pos))
else
(
match get_expr_type ctx e1 with
| Array(t, _, _) -> t
| t -> raise (Parse_error("typing error (array expected)", e.expr_pos))
)
| Rec(e1, m) ->
(
match get_expr_type ctx e1 with
| Record l ->
(
try
List.assoc m l
with
| Not_found -> raise (Parse_error("no such member", e1.expr_pos))
)
| _ -> raise (Parse_error("typing error (record expected)", e1.expr_pos))
)
| Var(v, []) ->
get_var_type ctx v
| Var(v, a) ->
(
try
match get_var_value ctx v with
| Function f ->
(
try
List.iter2
(fun d e ->
if
(
if d.def_pass_by_ref then
match d.def_type with
| Pointer t -> t
| _ -> raise (Parse_error("internal error (pointer expected for by ref)", v.var_pos))
else
d.def_type
)
<> get_expr_type ctx e then
raise (Parse_error("typing error", e.expr_pos))
) f.func_args a;
get_var_type ctx v
with
| Invalid_argument _ -> raise (Parse_error("wrong number of arguments", v.var_pos))
);
| _ -> raise (Parse_error("typing error (function expected)", v.var_pos))
with
| Not_found ->
raise (Parse_error("procedure " ^ v.var_name ^ " is used without having been declared", v.var_pos))
)
| Address_of e ->
Pointer (get_expr_type ctx e)
| Bang e ->
(
match get_expr_type ctx e with
| Pointer t -> t
| _ -> raise (Parse_error("typing error (pointer expected)", e.expr_pos))
)
| New t ->
t := resolve_user_type ctx !t;
Pointer !t
);
e.expr_type
in
let rec check_statement ctx stt =
match stt.stt_value with
| Assign(n, e) ->
let tn = get_expr_type ctx n
and te = get_expr_type ctx e in
if tn <> te then typing_error te tn e.expr_pos
| Compound l -> List.iter (check_statement ctx) l
| While(e, s) ->
if get_expr_type ctx e <> Boolean then
raise (Parse_error("typing error (boolean expected)", e.expr_pos))
else
check_statement ctx s
| If(e, s1, s2) ->
if get_expr_type ctx e <> Boolean then
raise (Parse_error("typing error (boolean expected)", e.expr_pos))
else
(
check_statement ctx s1;
check_statement ctx s2
)
| Return(e) ->
if get_expr_type ctx e <> rettype then
raise (Parse_error("typing error (" ^ string_of_type rettype ^ " expected)", e.expr_pos))
| Proc(v, l) ->
(
try
match get_var_value ctx v with
| Function f ->
(
try
List.iter2
(fun d e ->
if
(
if d.def_pass_by_ref then
match d.def_type with
| Pointer t -> t
| _ -> raise (Parse_error("internal error (pointer expected for by ref)", v.var_pos))
else
d.def_type
)
<> get_expr_type ctx e then
raise (Parse_error("typing error", e.expr_pos))
) f.func_args l;
if get_var_type ctx v <> Unit then
Log.warning ("Discading the value of a function line " ^ (string_of_int (fst stt.stt_pos)))
with
| Invalid_argument _ -> raise (Parse_error("wrong number of arguments", stt.stt_pos))
);
| _ -> raise (Parse_error("typing error (procedure expected)", stt.stt_pos))
with
| Not_found ->
raise (Parse_error("procedure " ^ v.var_name ^ " is used without having been declared", v.var_pos))
)
| Delete _
| Noop -> ()
in
let ctx = ref block_ctx in
let cur_env = ref (create_environment ()) in
let resolve_user_type t = resolve_user_type !ctx t in
let resolve_def_user_type d =
d.def_type <-
(
try
resolve_user_type d.def_type
with
| Parse_error(e, _) -> raise (Parse_error(e, d.def_pos))
)
in
iter_env
(fun n d ->
(
match d.def_value with
| Type t ->
(
try
d.def_value <- Type(resolve_user_type t)
with
| Parse_error(e, _) -> raise (Parse_error(e, d.def_pos))
)
| _ -> ()
);
resolve_def_user_type d;
(
match d.def_value with
| Function f ->
List.iter resolve_def_user_type f.func_args;
List.iter2 (fun a b -> b.Asm_ir.vd_type := asm_type a.def_type) f.func_args f.func_asm_def.Asm_ir.proc_args;
check_block f.func_value (add_def !cur_env n d :: !ctx) d.def_type
| Constant e ->
if not (is_constant (get_expr_nature !ctx e)) then
raise (Parse_error("typing error (constant expression expected)", e.expr_pos));
d.def_type <- get_expr_type !ctx e
| Type t ->
(
match t with
| Array(t, i, f) ->
if get_expr_type !ctx i <> Integer then
raise (Parse_error("typing error (integer expected)", i.expr_pos))
else if get_expr_type !ctx f <> Integer then
raise (Parse_error("typing error (integer expected)", f.expr_pos))
else if not (is_constant (get_expr_nature !ctx i)) then
raise (Parse_error("typing error (constant expression expected)", i.expr_pos))
else if not (is_constant (get_expr_nature !ctx f)) then
raise (Parse_error("typing error (constant expression expected)", f.expr_pos))
| Record _ -> ()
| _ -> raise (Parse_error("internal error (user type other than array or record defined)", d.def_pos))
)
| Variable -> ()
);
cur_env := add_def !cur_env n d;
ctx := !cur_env :: block_ctx
) block.block_env;
List.iter (check_statement (block.block_env :: block_ctx)) block.block_stts