diff options
| -rw-r--r-- | src/typing.ml | 982 |
1 files changed, 491 insertions, 491 deletions
diff --git a/src/typing.ml b/src/typing.ml index 110e2f8..d7f11eb 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -8,19 +8,19 @@ exception AmbiguousOverload let ty_assert x k = if not x then raise (Error (k)) let ty_error k = raise (Error (k)) let err_add_loc loc f = - try f() - with - | Error(k) -> raise (LocError(loc, k)) - | LocError(_, _) as e -> raise e - | Assert_failure (k, a, b) -> raise (LocError (loc, - "(unexpected) Assertion failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b))) - | Not_found -> raise (LocError (loc, "(unexpected) Not found")) - | Invalid_argument(k) -> raise (LocError (loc, "(unexpected) Invalid argument: "^k)) - | Match_failure(k, a, b) -> raise (LocError (loc, - "(unexpected) Match failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b))) - | NoCorrespondingPrototype -> raise (LocError (loc, "No corresponding prototype")) - | AmbiguousOverload -> raise (LocError (loc, "Ambiguous overload")) - | _ -> raise (LocError (loc, "(unexpected) Other error")) + try f() + with + | Error(k) -> raise (LocError(loc, k)) + | LocError(_, _) as e -> raise e + | Assert_failure (k, a, b) -> raise (LocError (loc, + "(unexpected) Assertion failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b))) + | Not_found -> raise (LocError (loc, "(unexpected) Not found")) + | Invalid_argument(k) -> raise (LocError (loc, "(unexpected) Invalid argument: "^k)) + | Match_failure(k, a, b) -> raise (LocError (loc, + "(unexpected) Match failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b))) + | NoCorrespondingPrototype -> raise (LocError (loc, "No corresponding prototype")) + | AmbiguousOverload -> raise (LocError (loc, "Ambiguous overload")) + | _ -> raise (LocError (loc, "(unexpected) Other error")) (* AST typés *) @@ -48,85 +48,85 @@ and texpr_desc = | TEIdent of ident | TEAssign of texpression * texpression | TECallFun of ident * texpression list (* changé : te -> ident *) - (* calls to non-virtual methods are compiled using TECallFun, with the object cons'ed at - the begining of the arguments expression list *) + (* calls to non-virtual methods are compiled using TECallFun, with the object cons'ed at + the begining of the arguments expression list *) | TECallVirtual of texpression * int * texpression list (* object * index in vtable * arguments *) | TEUnary of unop * texpression | TEBinary of texpression * binop * texpression - | TEMember of texpression * int (* object * position of member *) + | TEMember of texpression * int (* object * position of member *) | TENew of tcls * tproto option * texpression list and tstr_expression = - | TSEExpr of texpression - | TSEStr of string + | TSEExpr of texpression + | TSEStr of string and tstatement = { - ts_loc: loc; - ts_desc: ts_desc; - } + ts_loc: loc; + ts_desc: ts_desc; + } and ts_desc = - | TSEmpty - | TSExpr of texpression - | TSIf of texpression * tstatement * tstatement - | TSWhile of texpression * tstatement - | TSFor of texpression list * texpression option * texpression list * tstatement - | TSBlock of tblock - | TSReturn of texpression option - | TSDeclare of type_ref * ident - | TSDeclareAssignExpr of type_ref * ident * texpression - | TSDeclareAssignConstructor of typ * ident * tproto option * tident * texpression list (* a faire *) + | TSEmpty + | TSExpr of texpression + | TSIf of texpression * tstatement * tstatement + | TSWhile of texpression * tstatement + | TSFor of texpression list * texpression option * texpression list * tstatement + | TSBlock of tblock + | TSReturn of texpression option + | TSDeclare of type_ref * ident + | TSDeclareAssignExpr of type_ref * ident * texpression + | TSDeclareAssignConstructor of typ * ident * tproto option * tident * texpression list (* a faire *) (* Type of variable, variable name, constructor class name, constructor arguments *) - | TSWriteCout of tstr_expression list + | TSWriteCout of tstr_expression list and tblock = tstatement list and tproto = { - tp_virtual : int option; (* only used for class methods ; if none then not virtual, - if some then gives the index of the method in the vtable (same for all classes - of the hierarchy that have that method) *) - tp_loc : loc; - tp_name : ident; - tp_unique_ident : ident; (* label de la fonction dans le code assembleur *) - tp_class : tident option; (* p_class = none : standalone function *) - tp_ret_type : type_ref option; (* p_class = some and p_ret_type = none : constructor *) - tp_args : (type_ref * ident) list; + tp_virtual : int option; (* only used for class methods ; if none then not virtual, + if some then gives the index of the method in the vtable (same for all classes + of the hierarchy that have that method) *) + tp_loc : loc; + tp_name : ident; + tp_unique_ident : ident; (* label de la fonction dans le code assembleur *) + tp_class : tident option; (* p_class = none : standalone function *) + tp_ret_type : type_ref option; (* p_class = some and p_ret_type = none : constructor *) + tp_args : (type_ref * ident) list; } and tcls = { - tc_name : tident; - tc_size : int; - tc_super : tident option; - tc_vtable : (int * tproto) list; - tc_members : (typ * int) Smap.t; (* type du membre * position du membre dans les données de l'objet *) - tc_methods : tproto list; + tc_name : tident; + tc_size : int; + tc_super : tident option; + tc_vtable : (int * tproto) list; + tc_members : (typ * int) Smap.t; (* type du membre * position du membre dans les données de l'objet *) + tc_methods : tproto list; } let tproto_numbering = ref 1 let tproto_unique_number () = - let k = !tproto_numbering in - tproto_numbering := k + 1; - string_of_int k + let k = !tproto_numbering in + tproto_numbering := k + 1; + string_of_int k type env = { - e_globals : typ Smap.t; - e_funs : tproto list; - e_classes : tcls Smap.t; + e_globals : typ Smap.t; + e_funs : tproto list; + e_classes : tcls Smap.t; } and benv = { - b_pe : env; - b_locals : type_ref Smap.t; - b_class : tcls option; + b_pe : env; + b_locals : type_ref Smap.t; + b_class : tcls option; } type tdeclaration = - | TDGlobal of (typ * ident) - | TDFunction of (tproto * tblock) - | TDClass of tcls + | TDGlobal of (typ * ident) + | TDFunction of (tproto * tblock) + | TDClass of tcls type tprogram = { - prog_decls : tdeclaration list; - prog_env : env; + prog_decls : tdeclaration list; + prog_env : env; } (* Quelques fonctions utiles : *) @@ -135,13 +135,13 @@ let get_c env i = try Smap.find i env.e_classes with Not_found -> ty_error ("No such class: " ^ i) let rec bf env t = - let rec aux = function (* true si bien formé *) - | T_Int -> true - | TClass n -> - Smap.mem n env.e_classes - | TPoint t -> aux t - | _ -> false - in aux t + let rec aux = function (* true si bien formé *) + | T_Int -> true + | TClass n -> + Smap.mem n env.e_classes + | TPoint t -> aux t + | _ -> false + in aux t let num = function | T_Int -> true @@ -165,61 +165,61 @@ let build_type_or_ref vt = (* vt -> typ,bool = tr, true si ref *) | vt -> (see vt),false let rec subtype env a b = match a, b with - | T_Int, T_Int -> true - | T_Void, T_Void -> true - | Typenull, TPoint(_) -> true - | TPoint(ka), TPoint(kb) -> subtype env ka kb - | TClass(i), TClass(j) -> - if i = j then true - else let c = get_c env i in - (* NOT DONE : multiple supers *) - begin match c.tc_super with - | None -> false - | Some(k) -> subtype env (TClass k) (TClass j) - end - | _ -> false + | T_Int, T_Int -> true + | T_Void, T_Void -> true + | Typenull, TPoint(_) -> true + | TPoint(ka), TPoint(kb) -> subtype env ka kb + | TClass(i), TClass(j) -> + if i = j then true + else let c = get_c env i in + (* NOT DONE : multiple supers *) + begin match c.tc_super with + | None -> false + | Some(k) -> subtype env (TClass k) (TClass j) + end + | _ -> false let type_size env t = match t with - | T_Int | Typenull | TPoint(_) -> 4 - | T_Void -> 0 - | TClass(c) -> let c = get_c env c in c.tc_size + | T_Int | Typenull | TPoint(_) -> 4 + | T_Void -> 0 + | TClass(c) -> let c = get_c env c in c.tc_size (* pour la surcharge de fonctions *) let possible_protos env arg_type_list fun_list = - List.filter - (fun proto -> - try List.for_all2 - (fun (t_a, t_a_ref) (t_p, t_p_ref) -> - if t_p_ref && (not t_a_ref) then false else - subtype env t_a t_p) - arg_type_list (List.map fst proto.tp_args) - with Invalid_argument _ -> false) - fun_list + List.filter + (fun proto -> + try List.for_all2 + (fun (t_a, t_a_ref) (t_p, t_p_ref) -> + if t_p_ref && (not t_a_ref) then false else + subtype env t_a t_p) + arg_type_list (List.map fst proto.tp_args) + with Invalid_argument _ -> false) + fun_list let closest_proto env arg_type_list fun_list = - match possible_protos env arg_type_list fun_list with - | [] -> raise NoCorrespondingPrototype - | [p] -> p - | _ -> raise AmbiguousOverload + match possible_protos env arg_type_list fun_list with + | [] -> raise NoCorrespondingPrototype + | [p] -> p + | _ -> raise AmbiguousOverload let find_proto_in_class env cls name arg_type_list = - let rec aux = function - | None -> raise NoCorrespondingPrototype - | Some(k) -> let c = get_c env k in - let f = List.filter (fun p -> p.tp_name = name) c.tc_methods in - begin try closest_proto env arg_type_list f - with NoCorrespondingPrototype -> aux c.tc_super - end - in aux (Some cls) - + let rec aux = function + | None -> raise NoCorrespondingPrototype + | Some(k) -> let c = get_c env k in + let f = List.filter (fun p -> p.tp_name = name) c.tc_methods in + begin try closest_proto env arg_type_list f + with NoCorrespondingPrototype -> aux c.tc_super + end + in aux (Some cls) + let find_cls_mem env cls_name mem_name = - let rec aux = function - | None -> raise Not_found - | Some(k) -> let c = get_c env k in - begin try let mty, mi = Smap.find mem_name c.tc_members in - mty, mi - with Not_found -> aux c.tc_super - end - in aux (Some cls_name) + let rec aux = function + | None -> raise Not_found + | Some(k) -> let c = get_c env k in + begin try let mty, mi = Smap.find mem_name c.tc_members in + mty, mi + with Not_found -> aux c.tc_super + end + in aux (Some cls_name) (* -------------------------------------------- *) @@ -241,242 +241,242 @@ and get_expr env e = (* expression -> texpression,(ty,b) *) and compute_type env e = - let ttype = (TClass(match env.b_class with | Some c -> c.tc_name | None -> "#")) in - let e_this = - { te_loc = e.e_loc; - te_desc = TEThis; - type_expr = TPoint(ttype), false, true } in - let e_this_not_ptr = - { te_loc = e.e_loc; - te_desc = TEUnary(Deref, e_this); - type_expr = ttype, false, true; } in - match e.e_desc with (* expression -> te_desc,(typ,ref?,left?) *) + let ttype = (TClass(match env.b_class with | Some c -> c.tc_name | None -> "#")) in + let e_this = + { te_loc = e.e_loc; + te_desc = TEThis; + type_expr = TPoint(ttype), false, true } in + let e_this_not_ptr = + { te_loc = e.e_loc; + te_desc = TEUnary(Deref, e_this); + type_expr = ttype, false, true; } in + match e.e_desc with (* expression -> te_desc,(typ,ref?,left?) *) | EInt n -> TEInt n, (T_Int,false,false) (* false, : pas une ref, pas une val gauche*) | EBool b -> let n = (if b then 1 else 0) in - TEInt n, (T_Int,false,false) + TEInt n, (T_Int,false,false) | ENull -> TENull, (Typenull,false,false) | EIdent i -> - begin try - let t, r = Smap.find i env.b_locals in - TEIdent i, (t, r, true) - with Not_found -> - try match env.b_class with - | Some k -> let mty, mi = find_cls_mem env.b_pe k.tc_name i in - TEMember(e_this_not_ptr, mi), - (mty, false, true) - | None -> raise Not_found - with Not_found -> - try let t = Smap.find i env.b_pe.e_globals in - TEIdent i, (t, false, true) - with Not_found -> ty_error ("Undeclared identifier: " ^ i) - end + begin try + let t, r = Smap.find i env.b_locals in + TEIdent i, (t, r, true) + with Not_found -> + try match env.b_class with + | Some k -> let mty, mi = find_cls_mem env.b_pe k.tc_name i in + TEMember(e_this_not_ptr, mi), + (mty, false, true) + | None -> raise Not_found + with Not_found -> + try let t = Smap.find i env.b_pe.e_globals in + TEIdent i, (t, false, true) + with Not_found -> ty_error ("Undeclared identifier: " ^ i) + end | EAssign (e1,e2) -> let te1,(ty1,r3,b3) = get_expr0 env e1 in - let te2,(ty2,_,_) = get_expr0 env e2 in - ty_assert (b3 || r3) "Can only assign to lvalue"; - ty_assert (num ty1) "Cannot assign to non-numeric type (pointer type is numeric)"; - ty_assert (subtype env.b_pe ty2 ty1) "Incompatible types in assign"; - (* type num et ref compatibles ?*) - (TEAssign (te1,te2) ),(ty1,false,false) + let te2,(ty2,_,_) = get_expr0 env e2 in + ty_assert (b3 || r3) "Can only assign to lvalue"; + ty_assert (num ty1) "Cannot assign to non-numeric type (pointer type is numeric)"; + ty_assert (subtype env.b_pe ty2 ty1) "Incompatible types in assign"; + (* type num et ref compatibles ?*) + (TEAssign (te1,te2) ),(ty1,false,false) | EUnary (op,e) -> let te,(ty,b1,b2) = get_expr0 env e in - (match op with - | PreIncr | PostIncr | PreDecr | PostDecr -> - ty_assert (b2 = true) "Can only increment/decrement lvalue"; - ty_assert (ty = T_Int) "Can only increment/decrement integers"; - TEUnary(op,te),(T_Int,b1,false) - | Plus | Minus | Not -> - ty_assert (ty = T_Int) "Can only apply unary plus/minus/not to integers"; - TEUnary(op,te),(T_Int,false,false) - | Ref -> - ty_assert b2 "Can only reference lvalues"; - TEUnary(op,te),(TPoint ty,false,false) (* verif *) - | Deref -> - let t = (match ty with - | TPoint t -> t - | _ -> ty_error "Can only dereference pointer" ) in - TEUnary(op,te), (t,false,true) - ) + (match op with + | PreIncr | PostIncr | PreDecr | PostDecr -> + ty_assert (b2 = true) "Can only increment/decrement lvalue"; + ty_assert (ty = T_Int) "Can only increment/decrement integers"; + TEUnary(op,te),(T_Int,b1,false) + | Plus | Minus | Not -> + ty_assert (ty = T_Int) "Can only apply unary plus/minus/not to integers"; + TEUnary(op,te),(T_Int,false,false) + | Ref -> + ty_assert b2 "Can only reference lvalues"; + TEUnary(op,te),(TPoint ty,false,false) (* verif *) + | Deref -> + let t = (match ty with + | TPoint t -> t + | _ -> ty_error "Can only dereference pointer" ) in + TEUnary(op,te), (t,false,true) + ) | EBinary (e1,op,e2) -> let te1,(ty1,_,b1) = get_expr0 env e1 in - let te2,(ty2,_,b2) = get_expr0 env e2 in - (match op with - | Equal | NotEqual -> - ty_assert ((subtype env.b_pe ty1 ty2) || (subtype env.b_pe ty2 ty1)) - "Can only apply == or != to two values of compatible type"; - ty_assert (num ty1) "Can only apply == or != to pointers" - | Lt | Le | Gt | Ge - | Add | Sub | Mul | Div | Modulo - | Land | Lor -> - ty_assert (ty1 = T_Int) "Left operand of binop is not integer"; - ty_assert (ty2 = T_Int) "Right operand of binop is not integer" - ); (* vérifs *) - TEBinary(te1,op,te2),(T_Int,false,false) + let te2,(ty2,_,b2) = get_expr0 env e2 in + (match op with + | Equal | NotEqual -> + ty_assert ((subtype env.b_pe ty1 ty2) || (subtype env.b_pe ty2 ty1)) + "Can only apply == or != to two values of compatible type"; + ty_assert (num ty1) "Can only apply == or != to pointers" + | Lt | Le | Gt | Ge + | Add | Sub | Mul | Div | Modulo + | Land | Lor -> + ty_assert (ty1 = T_Int) "Left operand of binop is not integer"; + ty_assert (ty2 = T_Int) "Right operand of binop is not integer" + ); (* vérifs *) + TEBinary(te1,op,te2),(T_Int,false,false) | ECall (e,e_list) -> - (* TODO : look also within parent classes *) - let args_values = List.map (get_expr0 env) e_list in - let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in - - let obj, tproto = (match e.e_desc with - | EIdent i -> - let funs = List.filter (fun p -> p.tp_name = i) env.b_pe.e_funs in - begin match env.b_class with - | None -> None, closest_proto env.b_pe args_types funs - | Some k -> - begin try Some e_this_not_ptr, find_proto_in_class env.b_pe k.tc_name i args_types - with NoCorrespondingPrototype -> - None, closest_proto env.b_pe args_types funs - end - end - | EMember(e, i) -> - let e = type_expr env e in - begin match e.type_expr with - | TClass(k), a, b when a || b -> - Some e, find_proto_in_class env.b_pe k i args_types - | _ -> ty_error "Invalid argument type for method call (not a class, or not a lvalue)" - end - | _ -> ty_error "Calling something that is neither a function nor a method") in - let l_te = List.map fst args_values in - let ty,b = match tproto.tp_ret_type with - | None -> ty_error "Constructor cannot be called as function" - | Some (ty,b) -> ty,b in - begin match tproto.tp_virtual, obj with - | None, None -> - TECallFun(tproto.tp_unique_ident,l_te),(ty,b,false) - | None, Some(obj)-> - TECallFun(tproto.tp_unique_ident,obj::l_te),(ty,b,false) - | Some(idx), Some(obj) -> - TECallVirtual(obj, idx, l_te),(ty,b,false) - | _ -> ty_error "(should not happen) Virtual function applied to no object..." - end + (* TODO : look also within parent classes *) + let args_values = List.map (get_expr0 env) e_list in + let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in + + let obj, tproto = (match e.e_desc with + | EIdent i -> + let funs = List.filter (fun p -> p.tp_name = i) env.b_pe.e_funs in + begin match env.b_class with + | None -> None, closest_proto env.b_pe args_types funs + | Some k -> + begin try Some e_this_not_ptr, find_proto_in_class env.b_pe k.tc_name i args_types + with NoCorrespondingPrototype -> + None, closest_proto env.b_pe args_types funs + end + end + | EMember(e, i) -> + let e = type_expr env e in + begin match e.type_expr with + | TClass(k), a, b when a || b -> + Some e, find_proto_in_class env.b_pe k i args_types + | _ -> ty_error "Invalid argument type for method call (not a class, or not a lvalue)" + end + | _ -> ty_error "Calling something that is neither a function nor a method") in + let l_te = List.map fst args_values in + let ty,b = match tproto.tp_ret_type with + | None -> ty_error "Constructor cannot be called as function" + | Some (ty,b) -> ty,b in + begin match tproto.tp_virtual, obj with + | None, None -> + TECallFun(tproto.tp_unique_ident,l_te),(ty,b,false) + | None, Some(obj)-> + TECallFun(tproto.tp_unique_ident,obj::l_te),(ty,b,false) + | Some(idx), Some(obj) -> + TECallVirtual(obj, idx, l_te),(ty,b,false) + | _ -> ty_error "(should not happen) Virtual function applied to no object..." + end | EMember (e, id) -> - let e, (ty, r, l) = get_expr0 env e in - begin match ty with - | TClass(c_name) -> - begin try let mty, mi = find_cls_mem env.b_pe c_name id in - TEMember(e, mi), (mty, false, true) - with | Not_found -> ty_error ("Class " ^ c_name ^ " has no member " ^ id) - end - | _ -> ty_error "Cannot get member of expression that is not a class" - end + let e, (ty, r, l) = get_expr0 env e in + begin match ty with + | TClass(c_name) -> + begin try let mty, mi = find_cls_mem env.b_pe c_name id in + TEMember(e, mi), (mty, false, true) + with | Not_found -> ty_error ("Class " ^ c_name ^ " has no member " ^ id) + end + | _ -> ty_error "Cannot get member of expression that is not a class" + end | ENew (cls_name, args) -> - let c = get_c env.b_pe cls_name in - let args_values = List.map (get_expr0 env) args in - let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in - let candidates = List.filter (fun p -> p.tp_ret_type = None) c.tc_methods in - begin match candidates with - | [] -> - ty_assert (args = []) "Only default constructor exists and it has 0 arguments"; - TENew(c, None, []), (TPoint(TClass(cls_name)), false, false) - | _ -> - let p = closest_proto env.b_pe args_types candidates in - (* closest_proto makes sure the prototypes match, no problem here *) - let l_te = List.map fst args_values in - TENew(c, Some p, l_te), (TPoint(TClass(cls_name)), false, false) - end + let c = get_c env.b_pe cls_name in + let args_values = List.map (get_expr0 env) args in + let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in + let candidates = List.filter (fun p -> p.tp_ret_type = None) c.tc_methods in + begin match candidates with + | [] -> + ty_assert (args = []) "Only default constructor exists and it has 0 arguments"; + TENew(c, None, []), (TPoint(TClass(cls_name)), false, false) + | _ -> + let p = closest_proto env.b_pe args_types candidates in + (* closest_proto makes sure the prototypes match, no problem here *) + let l_te = List.map fst args_values in + TENew(c, Some p, l_te), (TPoint(TClass(cls_name)), false, false) + end | EThis -> - begin match env.b_class with - | Some c -> TEThis, (TPoint(TClass(c.tc_name)), false, true) - | None -> ty_error "Cannot use this outside of method" - end + begin match env.b_class with + | Some c -> TEThis, (TPoint(TClass(c.tc_name)), false, true) + | None -> ty_error "Cannot use this outside of method" + end (* Statements *) let rec type_stm ret_type env s = - err_add_loc s.s_loc (fun () -> - let d, ty = compute_type_stm ret_type env s in - { ts_loc = s.s_loc; ts_desc = d }, ty) + err_add_loc s.s_loc (fun () -> + let d, ty = compute_type_stm ret_type env s in + { ts_loc = s.s_loc; ts_desc = d }, ty) and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_desc,stm_type *) | SEmpty -> TSEmpty,env | SExpr e -> let te,(ty,_) = get_expr env e in (* verif ty est bien typé *) - (TSExpr te) , env + (TSExpr te) , env | SBlock b -> build_block ret_type env b | SReturn None -> - let ty, ref = ret_type in - ty_assert (ty = T_Void) "Function must return non-void value"; - (TSReturn None) , env + let ty, ref = ret_type in + ty_assert (ty = T_Void) "Function must return non-void value"; + (TSReturn None) , env | SReturn (Some e0) -> let te,(ty,r,l) = get_expr0 env e0 in - let rty, rref = ret_type in - ty_assert (rty = ty) "Invalid return type"; - ty_assert (if rref then r||l else true) "Function must return reference"; - TSReturn (Some te), env + let rty, rref = ret_type in + ty_assert (rty = ty) "Invalid return type"; + ty_assert (if rref then r||l else true) "Function must return reference"; + TSReturn (Some te), env | SIf (e,s1,s2) -> let te,(ty,_) = get_expr env e in - let ts1,ty1 = type_stm ret_type env s1 in (* vérifs règle *) - let ts2,ty2 = type_stm ret_type env s2 in - ty_assert (ty = T_Int) "Condition in if statement must be integer"; - (TSIf (te,ts1,ts2)) , env + let ts1,ty1 = type_stm ret_type env s1 in (* vérifs règle *) + let ts2,ty2 = type_stm ret_type env s2 in + ty_assert (ty = T_Int) "Condition in if statement must be integer"; + (TSIf (te,ts1,ts2)) , env | SFor (el1,eopt,el3,s) -> let tel1 = List.map (type_expr env) el1 in (* et fait les vérifs pr e1 et e3 ? *) - let tel3 = List.map (type_expr env) el3 in - let teopt = (match eopt with - | None -> None - | Some e -> let te,(ty,_) = get_expr env e in - ty_assert (ty = T_Int) "Condition in for statement must be integer"; - Some te) - in - ignore( type_stm ret_type env s ); (* vérifie i *) - let ts, _ = type_stm ret_type env s in (* fait le truc d'avant aussi *) - TSFor (tel1,teopt,tel3,ts) , env + let tel3 = List.map (type_expr env) el3 in + let teopt = (match eopt with + | None -> None + | Some e -> let te,(ty,_) = get_expr env e in + ty_assert (ty = T_Int) "Condition in for statement must be integer"; + Some te) + in + ignore( type_stm ret_type env s ); (* vérifie i *) + let ts, _ = type_stm ret_type env s in (* fait le truc d'avant aussi *) + TSFor (tel1,teopt,tel3,ts) , env (* traduire règles restantes du for*) | SWhile(e,s) -> let ts,tys = type_stm ret_type env s in - let te,(ty,_) = get_expr env e in - ty_assert (ty = T_Int) "Condition in while statement must be integer"; - TSWhile(te,ts),env + let te,(ty,_) = get_expr env e in + ty_assert (ty = T_Int) "Condition in while statement must be integer"; + TSWhile(te,ts),env (* pq while n'est pas dans les règles données ? *) | SDeclare(vt,i) -> let ty,b = build_type_or_ref vt in - ty_assert (bf env.b_pe ty) "Malformed type"; - ty_assert (not (Smap.mem i env.b_locals) ) "Variable redefinition"; - let env0 = - { b_pe = env.b_pe; - b_locals = Smap.add i (ty,b) env.b_locals; - b_class = env.b_class } in - TSDeclare( (ty,b) ,i) , env0 + ty_assert (bf env.b_pe ty) "Malformed type"; + ty_assert (not (Smap.mem i env.b_locals) ) "Variable redefinition"; + let env0 = + { b_pe = env.b_pe; + b_locals = Smap.add i (ty,b) env.b_locals; + b_class = env.b_class } in + TSDeclare( (ty,b) ,i) , env0 | SDeclareAssignExpr(vt,i,e) -> let ty,b = build_type_or_ref vt in - ty_assert (bf env.b_pe ty) "Malformed type"; - ty_assert (not (Smap.mem i env.b_locals)) "Variable redefinition"; - let te,(tye,r,l) = get_expr0 env e in - ty_assert (if b then r || l else true) "Can only assigne lvalue/reference to reference type var"; - ty_assert (subtype env.b_pe tye ty) "Invalid data type for assign."; - let env0 = - { b_pe = env.b_pe; - b_locals = Smap.add i (ty,b) env.b_locals; - b_class = env.b_class } in - TSDeclareAssignExpr( (ty,b) ,i,te) , env0 + ty_assert (bf env.b_pe ty) "Malformed type"; + ty_assert (not (Smap.mem i env.b_locals)) "Variable redefinition"; + let te,(tye,r,l) = get_expr0 env e in + ty_assert (if b then r || l else true) "Can only assigne lvalue/reference to reference type var"; + ty_assert (subtype env.b_pe tye ty) "Invalid data type for assign."; + let env0 = + { b_pe = env.b_pe; + b_locals = Smap.add i (ty,b) env.b_locals; + b_class = env.b_class } in + TSDeclareAssignExpr( (ty,b) ,i,te) , env0 | SDeclareAssignConstructor(vt,i,ti,e_l) -> - let ty, b = build_type_or_ref vt in - ty_assert (bf env.b_pe ty) "Malformed type"; - ty_assert (not (Smap.mem i env.b_locals)) "Variable redefinition"; - ty_assert (not b) "Cannot have reference on a newly created object"; - ty_assert (ty = (TClass ti)) "Invalid type for constructor"; - let c = get_c env.b_pe ti in - let args_values= List.map (get_expr0 env) e_l in - let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in - let candidates = List.filter (fun p -> p.tp_ret_type = None) c.tc_methods in - begin match candidates with - | [] -> - ty_assert (e_l = []) "Only default constructor exists and it has 0 arguments"; - TSDeclareAssignConstructor(ty, i, None, ti, []), env - | _ -> - let p = closest_proto env.b_pe args_types candidates in - (* closest_proto makes sure the prototypes match, no problem here *) - let l_te = List.map fst args_values in - let env0 = - { b_pe = env.b_pe; - b_locals = Smap.add i (ty,b) env.b_locals; - b_class = env.b_class } in - TSDeclareAssignConstructor(ty, i, Some p, ti, l_te), env0 - end + let ty, b = build_type_or_ref vt in + ty_assert (bf env.b_pe ty) "Malformed type"; + ty_assert (not (Smap.mem i env.b_locals)) "Variable redefinition"; + ty_assert (not b) "Cannot have reference on a newly created object"; + ty_assert (ty = (TClass ti)) "Invalid type for constructor"; + let c = get_c env.b_pe ti in + let args_values= List.map (get_expr0 env) e_l in + let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in + let candidates = List.filter (fun p -> p.tp_ret_type = None) c.tc_methods in + begin match candidates with + | [] -> + ty_assert (e_l = []) "Only default constructor exists and it has 0 arguments"; + TSDeclareAssignConstructor(ty, i, None, ti, []), env + | _ -> + let p = closest_proto env.b_pe args_types candidates in + (* closest_proto makes sure the prototypes match, no problem here *) + let l_te = List.map fst args_values in + let env0 = + { b_pe = env.b_pe; + b_locals = Smap.add i (ty,b) env.b_locals; + b_class = env.b_class } in + TSDeclareAssignConstructor(ty, i, Some p, ti, l_te), env0 + end | SWriteCout(str_e_list) -> let args = List.map - (fun e -> match e.se_desc with - | SEExpr e0 -> let te,(ty,_) = get_expr env {e_loc = e.se_loc; e_desc = e0} in - ty_assert (ty = T_Int) "Expected integer or string in cout<<"; TSEExpr te - | SEStr s -> TSEStr(s) (* osef *) - ) - str_e_list + (fun e -> match e.se_desc with + | SEExpr e0 -> let te,(ty,_) = get_expr env {e_loc = e.se_loc; e_desc = e0} in + ty_assert (ty = T_Int) "Expected integer or string in cout<<"; TSEExpr te + | SEStr s -> TSEStr(s) (* osef *) + ) + str_e_list in TSWriteCout(args) , env - + and build_block ret_type env b = (* utilisé ds compute_type_stm et def_global_fun *) let two_stms (env,l) s = let ts,env2 = type_stm ret_type env s in @@ -493,17 +493,17 @@ and get_block ret_type env b = (* Déclarations de fonction *) let parse_args env a = - let args = List.map - (fun (t, i) -> - let t, r = build_type_or_ref t in - ty_assert (bf env t) ("Malformed argument type for argument " ^ i ^ "."); - (t, r), i) - a in - let rec aux = function - | [] -> () - | p::q -> ty_assert (not (List.mem p q)) ("Argument name appears twice : " ^ p); aux q - in aux (List.map snd args); - args + let args = List.map + (fun (t, i) -> + let t, r = build_type_or_ref t in + ty_assert (bf env t) ("Malformed argument type for argument " ^ i ^ "."); + (t, r), i) + a in + let rec aux = function + | [] -> () + | p::q -> ty_assert (not (List.mem p q)) ("Argument name appears twice : " ^ p); aux q + in aux (List.map snd args); + args let get_fun env p b = (* p : proto b : block -> tp, tb, env2*) assert (p.p_class = None); @@ -512,32 +512,32 @@ let get_fun env p b = (* p : proto b : block -> tp, tb, env2*) (* Check there is not already a function with similar prototype *) let args_type = List.map fst ty_args in ty_assert (not (List.exists - (fun p -> p.tp_name = name && (List.map fst p.tp_args) = args_type) env.e_funs)) - ("Redefinition of function: " ^ name); + (fun p -> p.tp_name = name && (List.map fst p.tp_args) = args_type) env.e_funs)) + ("Redefinition of function: " ^ name); let ret_type = build_type_or_ref (match p.p_ret_type with - | Some k -> k - | None -> ty_error "Internal error (function with no return type)" ) in + | Some k -> k + | None -> ty_error "Internal error (function with no return type)" ) in (* Add to env *) let tproto = { - tp_loc = p.p_loc ; - tp_name = name ; - tp_unique_ident = name ^ (tproto_unique_number()); - tp_class = None ; - tp_virtual = None ; - tp_ret_type = Some ret_type ; - tp_args = ty_args; } in + tp_loc = p.p_loc ; + tp_name = name ; + tp_unique_ident = name ^ (tproto_unique_number()); + tp_class = None ; + tp_virtual = None ; + tp_ret_type = Some ret_type ; + tp_args = ty_args; } in let env2 = - { e_globals = env.e_globals; - e_funs = tproto::(env.e_funs); - e_classes = env.e_classes; } in + { e_globals = env.e_globals; + e_funs = tproto::(env.e_funs); + e_classes = env.e_classes; } in (* Build local env *) let locales = List.fold_left (* tr = (ty,ref?) *) - (fun envir (tr,i) -> Smap.add i tr envir) - Smap.empty - ty_args + (fun envir (tr,i) -> Smap.add i tr envir) + Smap.empty + ty_args in (* contexte ds l'instruction *) let contexte = { b_pe = env2; b_locals = locales; b_class = None } in let tb = get_block ret_type contexte b in (* vérif instructions typées*) @@ -546,168 +546,168 @@ let get_fun env p b = (* p : proto b : block -> tp, tb, env2*) (* Déclarations de classes *) let compute_tclass env c = - let cls_name = c.c_name in - ty_assert (not (Smap.mem cls_name env.e_classes)) ("Redeclaration of class " ^cls_name^"."); - (* artifice pour que la classe en train d'être définie puisse être utilisée par elle-même *) - let forward_def = {tc_name = cls_name; tc_size = 0; tc_super = None; tc_members = Smap.empty; tc_methods = []; tc_vtable = [] } in - let forward_env = { - e_globals = env.e_globals; - e_funs = env.e_funs; - e_classes = (Smap.add cls_name forward_def env.e_classes); } in - - let super, vtable, used = match c.c_supers with - | Some [] | None -> None, ref [], 0 - | Some [n] -> - begin try let c = get_c env n in - Some n, ref c.tc_vtable, c.tc_size (* copy parent vtable, will be modified when redefined members *) - with Not_found -> ty_error ("Super " ^ n ^ " does not exist or is not a class.") - end - | _ -> ty_error "Intentionnal sacrifice : multiple inheritance not supported." - in - let used = (if used = 0 then 4 else used) in (* If no supers, reserve space for vtable pointer *) - let (mem, mem_u), meth = List.fold_left - (fun ((mem, mem_u), meth) n -> match n with - | CVar(t, i) -> - let t, r = build_type_or_ref t in - ty_assert (not r) "Class members cannot be references."; - ty_assert (bf forward_env t) ("Malformed type for member " ^ i ^ "."); - ty_assert (t <> TClass(cls_name)) "Class cannot contain itself as a member."; - ty_assert (not (Smap.mem i mem)) ("Redefinition of class member " ^ i ^ " in class " ^ cls_name ^ "."); - let size = type_size env t in - ((Smap.add i (t, mem_u) mem, mem_u + size), meth) - | CMethod(proto, virt) -> - let m = err_add_loc proto.p_loc (fun () -> - ty_assert (proto.p_class = None) "Overqualification in prototype."; - ty_assert (proto.p_ret_type <> None || proto.p_name = cls_name) "Invalid name for constructor"; - (* Make sure prototype is well formed *) - let args = parse_args forward_env proto.p_args in - (* Make sure method is compatible with other declarations in this class *) - ty_assert (not (List.exists - (fun p -> p.tp_name = proto.p_name && (List.map fst p.tp_args) = (List.map fst args)) meth)) - ("Redefinition of function " ^ proto.p_name ^ " with same argument types."); - (* Check return type *) - let ret_type = match proto.p_ret_type with - | Some k -> Some (build_type_or_ref k) - | None -> None in - (* If method is redefined from a virtual method of a parent class, it becomes virtual with same offset - Else if method is virtual, it gets new offset ! - Else method is not virtual, everything is simple. *) - let rec check_super = function - | None -> None - | Some(n) -> let c = get_c env n in - try let proto = List.find - (fun p -> p.tp_name = proto.p_name && p.tp_virtual <> None && (List.map fst p.tp_args) = (List.map fst args)) - c.tc_methods - in Some (proto) - with Not_found -> check_super (c.tc_super) - in - let vproto_in_super = check_super super in - let virtl = match vproto_in_super with - | Some(k) -> k.tp_virtual - | None -> - if not virt then None - else (* allocate new spot in vtable *) - Some (List.fold_left (fun n (x, _) -> max n (x+4)) 0 !vtable) - in - (* Build proto *) - let tproto = - { tp_virtual = virtl; - tp_loc = proto.p_loc; - tp_name = proto.p_name; - tp_unique_ident = proto.p_name ^ (tproto_unique_number()) ; - tp_class = Some(cls_name); - tp_ret_type = ret_type; - tp_args = args; - } in - (* Add to vtable *) - begin match virtl with - | None -> () - | Some i -> - vtable := (i, tproto)::(List.remove_assoc i !vtable) - end; - tproto) in - (mem, mem_u), m::meth - ) ((Smap.empty, used), []) c.c_members in - { tc_name = cls_name; - tc_vtable = !vtable; - tc_size = mem_u; - tc_super = super; - tc_members = mem; - tc_methods = meth; } - -let get_method env proto block = (* return : TDFunction *) - match proto.p_class with - | None -> assert false - | Some(cls_name) -> - try let c = get_c env cls_name in - let args = parse_args env proto.p_args in - let ret_type = match proto.p_ret_type with - | Some k -> Some (build_type_or_ref k) - | None -> None in - (* Find prototype in class *) - begin try let cproto = List.find - (fun p -> p.tp_args = args && p.tp_ret_type = ret_type && p.tp_name = proto.p_name) c.tc_methods - in - let locals = List.fold_left - (fun env (tr, i) -> Smap.add i tr env) Smap.empty args in - let contexte = { - b_pe = env; - b_locals = locals; - b_class = Some c; } in - let tb = get_block (match ret_type with | None -> T_Void, false | Some k -> k) contexte block in - cproto, tb - with - | Not_found -> ty_error ("Implementation corresponds to no declared method of class " ^ cls_name) - end - with - | Not_found -> ty_error (cls_name ^ " is not defined.") - + let cls_name = c.c_name in + ty_assert (not (Smap.mem cls_name env.e_classes)) ("Redeclaration of class " ^cls_name^"."); + (* artifice pour que la classe en train d'être définie puisse être utilisée par elle-même *) + let forward_def = {tc_name = cls_name; tc_size = 0; tc_super = None; tc_members = Smap.empty; tc_methods = []; tc_vtable = [] } in + let forward_env = { + e_globals = env.e_globals; + e_funs = env.e_funs; + e_classes = (Smap.add cls_name forward_def env.e_classes); } in + + let super, vtable, used = match c.c_supers with + | Some [] | None -> None, ref [], 0 + | Some [n] -> + begin try let c = get_c env n in + Some n, ref c.tc_vtable, c.tc_size (* copy parent vtable, will be modified when redefined members *) + with Not_found -> ty_error ("Super " ^ n ^ " does not exist or is not a class.") + end + | _ -> ty_error "Intentionnal sacrifice : multiple inheritance not supported." + in + let used = (if used = 0 then 4 else used) in (* If no supers, reserve space for vtable pointer *) + let (mem, mem_u), meth = List.fold_left + (fun ((mem, mem_u), meth) n -> match n with + | CVar(t, i) -> + let t, r = build_type_or_ref t in + ty_assert (not r) "Class members cannot be references."; + ty_assert (bf forward_env t) ("Malformed type for member " ^ i ^ "."); + ty_assert (t <> TClass(cls_name)) "Class cannot contain itself as a member."; + ty_assert (not (Smap.mem i mem)) ("Redefinition of class member " ^ i ^ " in class " ^ cls_name ^ "."); + let size = type_size env t in + ((Smap.add i (t, mem_u) mem, mem_u + size), meth) + | CMethod(proto, virt) -> + let m = err_add_loc proto.p_loc (fun () -> + ty_assert (proto.p_class = None) "Overqualification in prototype."; + ty_assert (proto.p_ret_type <> None || proto.p_name = cls_name) "Invalid name for constructor"; + (* Make sure prototype is well formed *) + let args = parse_args forward_env proto.p_args in + (* Make sure method is compatible with other declarations in this class *) + ty_assert (not (List.exists + (fun p -> p.tp_name = proto.p_name && (List.map fst p.tp_args) = (List.map fst args)) meth)) + ("Redefinition of function " ^ proto.p_name ^ " with same argument types."); + (* Check return type *) + let ret_type = match proto.p_ret_type with + | Some k -> Some (build_type_or_ref k) + | None -> None in + (* If method is redefined from a virtual method of a parent class, it becomes virtual with same offset + Else if method is virtual, it gets new offset ! + Else method is not virtual, everything is simple. *) + let rec check_super = function + | None -> None + | Some(n) -> let c = get_c env n in + try let proto = List.find + (fun p -> p.tp_name = proto.p_name && p.tp_virtual <> None && (List.map fst p.tp_args) = (List.map fst args)) + c.tc_methods + in Some (proto) + with Not_found -> check_super (c.tc_super) + in + let vproto_in_super = check_super super in + let virtl = match vproto_in_super with + | Some(k) -> k.tp_virtual + | None -> + if not virt then None + else (* allocate new spot in vtable *) + Some (List.fold_left (fun n (x, _) -> max n (x+4)) 0 !vtable) + in + (* Build proto *) + let tproto = + { tp_virtual = virtl; + tp_loc = proto.p_loc; + tp_name = proto.p_name; + tp_unique_ident = proto.p_name ^ (tproto_unique_number()) ; + tp_class = Some(cls_name); + tp_ret_type = ret_type; + tp_args = args; + } in + (* Add to vtable *) + begin match virtl with + | None -> () + | Some i -> + vtable := (i, tproto)::(List.remove_assoc i !vtable) + end; + tproto) in + (mem, mem_u), m::meth + ) ((Smap.empty, used), []) c.c_members in + { tc_name = cls_name; + tc_vtable = !vtable; + tc_size = mem_u; + tc_super = super; + tc_members = mem; + tc_methods = meth; } + +let get_method env proto block = (* return : TDFunction *) + match proto.p_class with + | None -> assert false + | Some(cls_name) -> + try let c = get_c env cls_name in + let args = parse_args env proto.p_args in + let ret_type = match proto.p_ret_type with + | Some k -> Some (build_type_or_ref k) + | None -> None in + (* Find prototype in class *) + begin try let cproto = List.find + (fun p -> p.tp_args = args && p.tp_ret_type = ret_type && p.tp_name = proto.p_name) c.tc_methods + in + let locals = List.fold_left + (fun env (tr, i) -> Smap.add i tr env) Smap.empty args in + let contexte = { + b_pe = env; + b_locals = locals; + b_class = Some c; } in + let tb = get_block (match ret_type with | None -> T_Void, false | Some k -> k) contexte block in + cproto, tb + with + | Not_found -> ty_error ("Implementation corresponds to no declared method of class " ^ cls_name) + end + with + | Not_found -> ty_error (cls_name ^ " is not defined.") + (* Partie générique *) let compute_decl env d = - err_add_loc (d.d_loc) (fun () -> - match d.d_desc with - | DGlobal(t,i) -> let tr, r = build_type_or_ref t in - ty_assert (bf env tr) ("Malformed type for global var " ^ i); - ty_assert (not r) "Global cannot be reference"; - ty_assert (not (Smap.mem i env.e_globals)) ("Redeclaration of " ^ i); - ty_assert (not (List.exists (fun p -> p.tp_name = i) env.e_funs)) ("Redeclaration of: " ^ i ^ ", was previously a function"); - (TDGlobal(tr,i)) , - { e_globals = (Smap.add i tr env.e_globals); - e_funs = env.e_funs; - e_classes = env.e_classes } - (* on voudrait une liste de ident pr decl plsr en meme temps *) - | DFunction (p,b) -> - ty_assert (not (Smap.mem p.p_name env.e_globals)) ("Redeclaration of: " ^ p.p_name ^ ", was previously a global variable"); - begin match p.p_class with - | None -> - let tp, tb, env2 = get_fun env p b in - TDFunction(tp, tb), env2 - | Some _ -> - let tp, tb = get_method env p b in - (TDFunction(tp, tb)), env(* env is not modified *) - end - | DClass c -> - let tc = compute_tclass env c in - (TDClass tc), - { e_globals = env.e_globals; - e_funs = env.e_funs; - e_classes = Smap.add c.c_name tc env.e_classes; } - ) + err_add_loc (d.d_loc) (fun () -> + match d.d_desc with + | DGlobal(t,i) -> let tr, r = build_type_or_ref t in + ty_assert (bf env tr) ("Malformed type for global var " ^ i); + ty_assert (not r) "Global cannot be reference"; + ty_assert (not (Smap.mem i env.e_globals)) ("Redeclaration of " ^ i); + ty_assert (not (List.exists (fun p -> p.tp_name = i) env.e_funs)) ("Redeclaration of: " ^ i ^ ", was previously a function"); + (TDGlobal(tr,i)) , + { e_globals = (Smap.add i tr env.e_globals); + e_funs = env.e_funs; + e_classes = env.e_classes } + (* on voudrait une liste de ident pr decl plsr en meme temps *) + | DFunction (p,b) -> + ty_assert (not (Smap.mem p.p_name env.e_globals)) ("Redeclaration of: " ^ p.p_name ^ ", was previously a global variable"); + begin match p.p_class with + | None -> + let tp, tb, env2 = get_fun env p b in + TDFunction(tp, tb), env2 + | Some _ -> + let tp, tb = get_method env p b in + (TDFunction(tp, tb)), env(* env is not modified *) + end + | DClass c -> + let tc = compute_tclass env c in + (TDClass tc), + { e_globals = env.e_globals; + e_funs = env.e_funs; + e_classes = Smap.add c.c_name tc env.e_classes; } + ) let prog p = let decls, env = ( List.fold_left (fun (decls, env) decl -> - let decl_p, env2 = compute_decl env decl in - decl_p::decls, env2) + let decl_p, env2 = compute_decl env decl in + decl_p::decls, env2) ([],{ e_globals = Smap.empty; e_funs = []; e_classes = Smap.empty }) p ) in ty_assert (List.exists - (fun tp -> tp.tp_class = None && tp.tp_name = "main" - && tp.tp_args = [] && tp.tp_ret_type = Some (T_Int,false)) - env.e_funs) "No 'int main()' function defined in program..."; + (fun tp -> tp.tp_class = None && tp.tp_name = "main" + && tp.tp_args = [] && tp.tp_ret_type = Some (T_Int,false)) + env.e_funs) "No 'int main()' function defined in program..."; { prog_decls = List.rev decls; prog_env = env } |