diff options
Diffstat (limited to 'src/typing.ml')
| -rw-r--r-- | src/typing.ml | 201 |
1 files changed, 102 insertions, 99 deletions
diff --git a/src/typing.ml b/src/typing.ml index 53afe0f..9eabf4e 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -69,7 +69,7 @@ and ts_desc = | TSReturn of texpression option | TSDeclare of type_ref * ident | TSDeclareAssignExpr of type_ref * ident * texpression - | TSDeclareAssignConstructor of type_ref * ident * tident * texpression list (* a faire *) + | 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 and tblock = tstatement list @@ -114,8 +114,8 @@ type tprogram = { (* Quelques fonctions utiles : *) -let find_v i env = - try Smap.find i env.e_globals with Not_found -> ty_error ("No such global variable: " ^ i) +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é *) @@ -139,7 +139,7 @@ let build_type_or_ref vt = (* vt -> typ,bool = tr, true si ref *) | TPtr vt -> TPoint (see vt) | TVoid -> T_Void | TInt -> T_Int - | TRef _ -> ty_error ("Unexpected reference type - no pionters on references allowed") + | TRef _ -> ty_error ("Unexpected reference type - no pointers on references allowed") | TIdent tid -> TClass tid in match vt with @@ -147,54 +147,33 @@ let build_type_or_ref vt = (* vt -> typ,bool = tr, true si ref *) | TRef vt -> (see vt),true (* indique qu'il s'agit d'une ref *) | vt -> (see vt),false -let rec subtype_d env a b = match a, b with (* returns distance *) - | T_Int, T_Int -> true, 0 - | T_Void, T_Void -> true, 0 - | Typenull, TPoint(_) -> true, 0 - | TPoint(ka), TPoint(kb) -> subtype_d env ka kb +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, 0 - else begin try let c = Smap.find i env.e_classes in - begin let d = ref None in - List.iter (fun s -> match subtype_d env (TClass s) (TClass j) with - | false, _ -> () - | true, n -> d := match !d with | None -> Some n | Some d -> Some (if d < n then d else n)) - c.tc_supers; - match !d with - | Some d -> true, d+1 - | None -> false, 0 - end - with | Not_found -> false, 0 end - | _ -> false, 0 -let subtype env a b = fst (subtype_d env a b) - + if i = j then true + else let c = get_c env i in + List.exists (fun k -> subtype env (TClass k) (TClass j)) c.tc_supers + | _ -> false (* pour la surcharge de fonctions *) let closest_proto env arg_type_list fun_list = - let p = ref None in - List.iter (fun f -> - let proto = f in - try - let k = List.fold_left2 - (fun d (t_a, t_a_ref) (t_p, t_p_ref) -> match d with - | None -> None - | Some d -> - if t_p_ref && (not t_a_ref) then None else - match subtype_d env t_a t_p with - | false, _ -> None - | true, d_a -> Some (d + d_a)) - (Some 0) arg_type_list (List.map fst proto.tp_args) in - match k with - | None -> () - | Some d -> match !p with - | None -> p := Some(d, f) - | Some(dd, _) -> if (d < dd) then p := Some(d, f) - else if (d = dd) then ty_error "Ambiguous overload" - with Invalid_argument _ -> ()) fun_list; - match !p with - | None -> None - | Some(_, f) -> Some f - + match 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 + with + | [] -> ty_error "No corresponding prototype" + | [p] -> p + | _ -> ty_error "Ambiguous overload" + (* -------------------------------------------- *) (* On passe aux choses sérieuses *) @@ -214,10 +193,15 @@ and get_expr env e = (* expression -> texpression,(ty,b) *) (te,(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 = TClass(match env.b_class with | Some c -> c.tc_name | None -> "#"), false, true } in + { 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*) @@ -231,7 +215,7 @@ and compute_type env e = with Not_found -> try match env.b_class with | Some k -> let ty = Smap.find i k.tc_members in - TEMember(e_this, i), + TEMember(e_this_not_ptr, i), (ty, false, true) | None -> raise Not_found with Not_found -> @@ -288,15 +272,13 @@ and compute_type env e = | Some k -> begin match List.filter (fun p -> p.tp_name = i) k.tc_methods with | [] -> None, i, funs - | l -> Some e_this, i, l + | l -> Some e_this_not_ptr, i, l end end | EMember(e, i) -> let e = type_expr env e in let c = match e.type_expr with - | TClass(k), a, b when a || b -> - begin try Smap.find k env.b_pe.e_classes with - Not_found -> ty_error ("Unknown class " ^ k ^ " (should not happen)") end + | TClass(k), a, b when a || b -> get_c env.b_pe k | _ -> ty_error "Invalid argument type for method call (not a class, or not a lvalue)" in Some e, i, List.filter (fun p -> p.tp_name = i) (c.tc_methods) @@ -307,43 +289,45 @@ and compute_type env e = | l -> (* handle overload *) let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in - let f = closest_proto env.b_pe args_types candidates in - begin match f with - | None -> ty_error "No corresponding function" - | Some(p) -> p - end + closest_proto env.b_pe args_types candidates in - (* vérif ici pour adresse/valeur, ici on test seulement - que ce sont les mêmes types, pas d'adressage de pris en compte *) let l_te = List.map fst args_values in - (* que les te de e_list*) let ty,b = match tproto.tp_ret_type with - | None -> assert false (* no return type only happens for constructors, and - constructors cannot be called as functions *) + | None -> ty_error "Constructor cannot be called as function" | Some (ty,b) -> ty,b in TECallFun(name,l_te),(ty,b,false) - | EMember _ -> ty_error "Not implemented (member)" + | EMember (e, id) -> + let e, (ty, r, l) = get_expr0 env e in + begin match ty with + | TClass(c_name) -> + let c = get_c env.b_pe c_name in + (* TODO : also look in super classes *) + begin try let mty = Smap.find id c.tc_members in + TEMember(e, id), (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) -> - begin try let c = Smap.find cls_name env.b_pe.e_classes 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 - 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 proto = closest_proto env.b_pe args_types candidates in - match proto with - | Some (p) -> - (* 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) - | None -> ty_error "No matching prototype" - with - | Not_found -> ty_error ("No such class: " ^ cls_name) + 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 - | EThis -> ty_error "Not implemented (this)" (* Statements *) @@ -362,10 +346,10 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des 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) = get_expr env e0 in + | 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 else true) "Function must return reference"; + 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 *) @@ -398,16 +382,16 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des 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 | SWriteCout(str_e_list) -> let args = List.map @@ -419,7 +403,26 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des str_e_list in TSWriteCout(args) , env - | SDeclareAssignConstructor(vt,i,ti,e_l) -> ty_error "TODO" + | 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 + TSDeclareAssignConstructor(ty, i, Some p, ti, l_te), env + end and build_block ret_type env b = (* utilisé ds compute_type_stm et def_global_fun *) let two_stms (env,l) s = |