let rec check_block block block_ctx =
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
let def = get_def c name in
def.def_used <- true; def
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_def_value ctx v.var_name
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
| Fun -> 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 -> Fun
| _ -> 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
| Rec(_, _)
| Arr(_, _) -> Varb
and get_expr_type ctx e =
if e.expr_type = Unknown_type then
e.expr_type <-
(
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 then
typing_error te1 Integer e1.expr_pos
else if te2 <> Integer then
typing_error te2 Integer e2.expr_pos
else 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
| Var(v, []) ->
get_var_type ctx v
| Var(v, _) -> failwith "not yet implemented"
| 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))
)
);
e.expr_type
in
let rec check_statement ctx stt =
match stt.stt_value with
| Assign(n, e) ->
let tn = get_var_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
)
| Proc(v, l) ->
(
try
match get_var_value ctx v with
| Procedure (a, _) ->
(
try
List.iter2
(fun d e ->
if d.def_type <> get_expr_type ctx e then
raise (Parse_error("typing error", e.expr_pos))
) a l
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))
)
| ExtProc(n, l) ->
(
match n with
| "writeInt" ->
if List.length l <> 1 then raise (Parse_error("wrong number of arguments", stt.stt_pos));
if get_expr_type ctx (List.hd l) <> Integer then raise (Parse_error("typing error (integer expected)", (List.hd l).expr_pos));
)
| Noop -> ()
in
let ctx = ref block_ctx in
let cur_env = ref (create_environment ()) in
let rec resolve_user_type 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", (0, 0)))
with
| Not_found ->
raise (Parse_error("user type " ^ tn ^ " is used without having been declared", (0, 0)))
in
match t with
| User_type tn -> get_user_type_def tn
| Array(t, i, f) -> Array(resolve_user_type t, i, f)
| Record l ->
Record((List.map (fun (n, t) -> n, resolve_user_type t)) l)
| _ -> t
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))
)
| _ -> ()
);
d.def_type <-
(
try
resolve_user_type d.def_type
with
| Parse_error(e, _) -> raise (Parse_error(e, d.def_pos))
);
(
match d.def_value with
| Procedure(a, b) -> check_block b !ctx
| 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))
)
| Function(_, _) -> failwith "functions are not yet implemented"
| Variable
| Variable_ref -> ()
);
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