diff options
| -rw-r--r-- | src/ast.ml | 3 | ||||
| -rw-r--r-- | src/parser.mly | 4 | ||||
| -rw-r--r-- | src/pretty.ml | 3 | ||||
| -rw-r--r-- | src/pretty_typing.ml | 48 | ||||
| -rw-r--r-- | src/typing.ml | 263 |
5 files changed, 202 insertions, 119 deletions
@@ -84,8 +84,7 @@ type proto = { type cls_mem = | CVar of var_type * ident - | CMethod of proto - | CVirtualMethod of proto + | CMethod of proto * bool (* is method virtual *) type cls = { c_name : tident; diff --git a/src/parser.mly b/src/parser.mly index 2b50797..3d1eb22 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -103,9 +103,9 @@ member: | k = typed_vars SEMICOLON { List.map (fun (x, y) -> CVar(x, y)) k } | p = cls_proto SEMICOLON - { [ CMethod(p) ] } + { [ CMethod(p, false) ] } | VIRTUAL p = cls_proto SEMICOLON - { [ CVirtualMethod(p) ] } + { [ CMethod(p, true) ] } ; cls_proto: diff --git a/src/pretty.ml b/src/pretty.ml index 4420ac1..6144cf3 100644 --- a/src/pretty.ml +++ b/src/pretty.ml @@ -146,8 +146,7 @@ let print_class_decl c = (List.fold_left (fun x t -> x ^ " public " ^ t) "" s)) ^ " {\n"); List.iter (function | CVar(t, i) -> print_string (" " ^ i ^ " : " ^ (var_type_str t) ^ "\n") - | CMethod(p) -> print_string (" " ^ (proto_str p) ^ "\n") - | CVirtualMethod(p) -> print_string (" virtual " ^ (proto_str p) ^ "\n") + | CMethod(p, v) -> print_string ((if v then " virtual " else " ") ^ (proto_str p) ^ "\n") ) c.c_members; print_string "}\n" diff --git a/src/pretty_typing.ml b/src/pretty_typing.ml index 2e0d321..1da6f24 100644 --- a/src/pretty_typing.ml +++ b/src/pretty_typing.ml @@ -9,6 +9,15 @@ open Parser open Typing open Ast +let repl_nl s = + let k = ref "" in + for i = 0 to String.length s - 1 do + if s.[i] = '\n' then + k := !k ^ "\\n" + else + k := !k ^ (String.make 1 s.[i]) + done; !k + let csl f l = List.fold_left (fun x t -> (if x = "" then "" else x ^ ", ") ^ (f t)) "" l @@ -25,7 +34,7 @@ let unop_str = function let rec var_type_str = function | T_Void -> "void" | T_Int -> "int" | TPoint(k) -> "*" ^ (var_type_str k) - | TClass s -> "" + | TClass s -> s | Typenull -> "NULL" let rec expr_string e = match e.te_desc with | TEInt(i) -> string_of_int i @@ -37,9 +46,12 @@ let rec expr_string e = match e.te_desc with (* ici, le second ast a changé par rapport au premier *) | TEUnary(e, f) -> (unop_str e) ^ (expr_string f) | TEBinary(e1, o, e2) -> "(" ^ (expr_string e1) ^ " " ^ (binop_str o) ^ " " ^ (expr_string e2) ^ ")" -(* | TEMember(e1, x) -> "(" ^ (expr_string e1) ^ ")." ^ x - | TENew(c, arg) -> "new " ^ c ^ " (" ^ (csl expr_string arg) ^ ")"*) - | _ -> "" + | TEMember(e1, i) -> "(" ^ (expr_string e1) ^ ")@" ^ (string_of_int i) + | TENew(c, proto, arg) -> "new " ^ c.tc_name + ^ (match proto with | None -> "" | Some p -> " ." ^ p.tp_unique_ident) + ^ " (" ^ (csl expr_string arg) ^ ")" + | TECallVirtual(exp, pos, args) -> + "(" ^ (expr_string exp) ^ ")#" ^ (string_of_int pos) ^ "(" ^ (csl expr_string args) ^ ")" let rec print_stmt l x = for i = 1 to l do print_string " " done; @@ -73,7 +85,7 @@ let rec print_stmt l x = (List.fold_left (fun x k -> x ^ " << " ^ (match k with | TSEExpr e -> expr_string e | TSEStr("\n") -> "std::endl" - | TSEStr s -> "`" ^ s ^ "`")) "" k) ^ "\n") + | TSEStr s -> "\"" ^ (repl_nl s) ^ "\"")) "" k) ^ "\n") and print_block n b = let prefix = String.make n ' ' in @@ -91,17 +103,20 @@ let proto_str p = ) p.tp_args) ^ ") : " ^ (match p.tp_ret_type with | Some (ty,b) -> var_type_str ty | None -> "constructor") + ^ " ." ^ p.tp_unique_ident + ^ (match p.tp_virtual with | None -> "" | Some k -> " #" ^ (string_of_int k)) -(*let print_class_decl c = - print_string ("class " ^ c.c_name ^ - (match c.c_supers with | None -> "" | Some(s) -> " : " ^ - (List.fold_left (fun x t -> x ^ " public " ^ t) "" s)) ^ " {\n"); - List.iter (function - | CVar(t, i) -> print_string (" " ^ i ^ " : " ^ (var_type_str t) ^ "\n") - | CMethod(p) -> print_string (" " ^ (proto_str p) ^ "\n") - | CVirtualMethod(p) -> print_string (" virtual " ^ (proto_str p) ^ "\n") - ) c.c_members; - print_string "}\n"*) +let print_class_decl c = + print_string ("class " ^ c.tc_name ^ " (size : " ^ (string_of_int c.tc_size) ^ ")"^ + (match c.tc_super with | None -> "" | Some(k) -> " : "^ k) ^" {\n"); + print_string " members:\n"; + Smap.iter (fun name (t, pos) -> print_string (" " ^ name ^ " : " ^ (var_type_str t) + ^ " @" ^ (string_of_int pos) ^ "\n")) c.tc_members; + print_string " methods:\n"; + List.iter(fun p -> print_string (" " ^ (proto_str p) ^ "\n")) c.tc_methods; + print_string " vtable:\n"; + List.iter(fun (i, p) -> print_string (" #" ^ (string_of_int i) ^ ": ." ^ (p.tp_unique_ident) ^ "\n")) c.tc_vtable; + print_string "}\n" let print_prog p = List.iter (function @@ -109,7 +124,8 @@ let print_prog p = print_string ("decl " ^ i ^ " : " ^ (var_type_str ty) ^ "\n") | TDFunction(p,b) -> print_string (proto_str p ^"\n"); print_block 0 b - | TDClass(c) -> () (* print_class_decl c *) + | TDClass(c) -> + print_class_decl c ) p.prog_decls diff --git a/src/typing.ml b/src/typing.ml index a87bf16..110e2f8 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -3,6 +3,8 @@ open Ast (* Gestion des erreurs *) exception Error of string exception LocError of loc * string +exception NoCorrespondingPrototype +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 = @@ -16,6 +18,8 @@ let err_add_loc loc f = | 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 *) @@ -46,10 +50,10 @@ and texpr_desc = | 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 *) - | TECallVirtual of texpression * ident * texpression list (* TODO (c'est le bazar) *) + | TECallVirtual of texpression * int * texpression list (* object * index in vtable * arguments *) | TEUnary of unop * texpression | TEBinary of texpression * binop * texpression - | TEMember of texpression * ident + | TEMember of texpression * int (* object * position of member *) | TENew of tcls * tproto option * texpression list and tstr_expression = @@ -77,7 +81,9 @@ and ts_desc = and tblock = tstatement list and tproto = { - tp_virtual : bool; (* only used for class methods *) + 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 *) @@ -88,8 +94,10 @@ and tproto = { and tcls = { tc_name : tident; - tc_supers : tident list; - tc_members : typ Smap.t; + 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; } @@ -164,12 +172,21 @@ let rec subtype env a b = match a, b with | TClass(i), TClass(j) -> 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 + (* 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 + (* pour la surcharge de fonctions *) -let closest_proto env arg_type_list fun_list = - match List.filter +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) -> @@ -178,10 +195,31 @@ let closest_proto env arg_type_list fun_list = arg_type_list (List.map fst proto.tp_args) with Invalid_argument _ -> false) fun_list - with - | [] -> ty_error "No corresponding prototype" +let closest_proto env arg_type_list fun_list = + match possible_protos env arg_type_list fun_list with + | [] -> raise NoCorrespondingPrototype | [p] -> p - | _ -> ty_error "Ambiguous overload" + | _ -> 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 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) (* -------------------------------------------- *) @@ -201,6 +239,7 @@ and get_expr env e = (* expression -> texpression,(ty,b) *) let (ty,b,_) = te.type_expr in (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 = @@ -223,9 +262,9 @@ and compute_type env e = TEIdent i, (t, r, true) with Not_found -> try match env.b_class with - | Some k -> let ty = Smap.find i k.tc_members in - TEMember(e_this_not_ptr, i), - (ty, false, true) + | 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 @@ -273,50 +312,47 @@ and compute_type env e = TEBinary(te1,op,te2),(T_Int,false,false) | ECall (e,e_list) -> (* TODO : look also within parent classes *) - let obj, name, candidates = (match e.e_desc with + 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, i, funs + | None -> None, closest_proto env.b_pe args_types funs | Some k -> - begin match List.filter (fun p -> p.tp_name = i) k.tc_methods with - | [] -> None, i, funs - | l -> Some e_this_not_ptr, i, l + 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 - let c = match e.type_expr with - | TClass(k), a, b when a || b -> get_c env.b_pe k + 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)" - in - Some e, i, List.filter (fun p -> p.tp_name = i) (c.tc_methods) + end | _ -> ty_error "Calling something that is neither a function nor a method") in - let args_values = List.map (get_expr0 env) e_list in - let tproto = match candidates with - | [] -> ty_error ("No such function: " ^ name) - | l -> - (* handle overload *) - let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in - closest_proto env.b_pe args_types candidates - in - let l_te = List.map fst args_values in - let l_te = match obj with - | None -> l_te - | Some(obj_e) -> obj_e :: l_te 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 - ty_assert (not tproto.tp_virtual) "Virtual methods not implemented yet."; - TECallFun(tproto.tp_unique_ident,l_te),(ty,b,false) + 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) -> - 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) + 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" @@ -490,7 +526,7 @@ let get_fun env p b = (* p : proto b : block -> tp, tb, env2*) tp_name = name ; tp_unique_ident = name ^ (tproto_unique_number()); tp_class = None ; - tp_virtual = false ; + tp_virtual = None ; tp_ret_type = Some ret_type ; tp_args = ty_args; } in let env2 = @@ -509,62 +545,101 @@ let get_fun env p b = (* p : proto b : block -> tp, tb, env2*) (* Déclarations de classes *) -let rec compute_tclass env c = - let name = c.c_name in - ty_assert (not (Smap.mem name env.e_classes)) ("Redeclaration of class " ^name^"."); - let supers = match c.c_supers with | None -> [] | Some k -> k in - List.iter (fun n -> - ty_assert (Smap.mem n env.e_classes) - ("Super " ^ n ^ " does not exist or is not a class.")) supers; - let cls_tmp = {tc_name = name; tc_supers = supers; tc_members = Smap.empty; tc_methods = [] } in - let t_env = { +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 name cls_tmp env.e_classes); } in - let mem, meth = List.fold_left - (fun (mem, meth) n -> match n with + 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 t_env t) ("Malformed type for member " ^ i ^ "."); - ty_assert (t <> TClass(name)) "Class cannot contain itself as a member."; - ty_assert (not (Smap.mem i mem)) ("Redefinition of class member " ^ i ^ " in class " ^ name ^ "."); - (Smap.add i t mem, meth) - | CMethod(p) -> - let m = err_add_loc p.p_loc (fun () -> (build_method t_env name meth false p)) in - mem, m::meth - | CVirtualMethod(p) -> - let m = err_add_loc p.p_loc (fun () -> (build_method t_env name meth true p)) in - mem, m::meth - ) (Smap.empty, []) c.c_members in - { tc_name = name; - tc_supers = supers; + 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; } -and build_method env cls_name cls_mems virt proto = - 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 env proto.p_args in - (* TODO Make sure method is compatible with parents and other declarations *) - (* Check return type *) - let ret_type = match proto.p_ret_type with - | Some k -> Some (build_type_or_ref k) - | None -> None in - { tp_virtual = virt; - 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; - } let get_method env proto block = (* return : TDFunction *) match proto.p_class with | None -> assert false | Some(cls_name) -> - try let c = Smap.find cls_name env.e_classes in + 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) @@ -580,13 +655,7 @@ let get_method env proto block = (* return : TDFunction *) 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 - { tp_virtual = cproto.tp_virtual; - tp_loc = proto.p_loc; - tp_name = proto.p_name; - tp_unique_ident = proto.p_name ^ (tproto_unique_number()) ; - tp_class = proto.p_class; - tp_ret_type = ret_type; - tp_args = args }, tb + cproto, tb with | Not_found -> ty_error ("Implementation corresponds to no declared method of class " ^ cls_name) end @@ -639,7 +708,7 @@ let prog p = (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 = decls; prog_env = env } + { prog_decls = List.rev decls; prog_env = env } |