diff options
Diffstat (limited to 'bytecomp/translclass.ml')
| -rw-r--r-- | bytecomp/translclass.ml | 80 |
1 files changed, 52 insertions, 28 deletions
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 5c8f819a8..59153bd67 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -22,7 +22,7 @@ open Translcore (* XXX Rajouter des evenements... *) -type error = Illegal_class_expr +type error = Illegal_class_expr | Tags of label * label exception Error of Location.t * error @@ -211,16 +211,24 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = (inh_init, lfunction [env] (subst_env env inh_init obj_init)) -let bind_method tbl public_methods lab id cl_init = - if List.mem lab public_methods then - Llet(Alias, id, Lvar (meth lab), cl_init) - else - Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), - cl_init) - -let bind_methods tbl public_methods meths cl_init = - Meths.fold (bind_method tbl public_methods) meths cl_init +let bind_method tbl lab id cl_init = + Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), + cl_init) + +let bind_methods tbl meths cl_init = + let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in + let len = List.length methl in + if len < 2 then Meths.fold (bind_method tbl) meths cl_init else + let ids = Ident.create "ids" in + let i = ref len in + Llet(StrictOpt, ids, + Lapply (oo_prim "get_method_labels", + [Lvar tbl; transl_meth_list (List.map fst methl)]), + List.fold_right + (fun (lab,id) lam -> + decr i; Llet(StrictOpt, id, Lprim(Pfield !i, [Lvar ids]), lam)) + methl cl_init) let output_methods tbl vals methods lam = let lam = @@ -241,7 +249,7 @@ let rec ignore_cstrs cl = | Tclass_apply (cl, _) -> ignore_cstrs cl | _ -> cl -let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl = +let rec build_class_init cla cstr inh_init cl_init msubst top cl = match cl.cl_desc with Tclass_ident path -> begin match inh_init with @@ -263,7 +271,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl = Cf_inher (cl, vals, meths) -> let cl_init = output_methods cla values methods cl_init in let inh_init, cl_init = - build_class_init cla pub_meths false inh_init + build_class_init cla false inh_init (transl_vals cla false false vals (transl_super cla str.cl_meths meths cl_init)) msubst top cl in @@ -304,18 +312,18 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl = (inh_init, cl_init, [], []) in let cl_init = output_methods cla values methods cl_init in - (inh_init, bind_methods cla pub_meths str.cl_meths cl_init) + (inh_init, bind_methods cla str.cl_meths cl_init) | Tclass_fun (pat, vals, cl, _) -> let (inh_init, cl_init) = - build_class_init cla pub_meths cstr inh_init cl_init msubst top cl + build_class_init cla cstr inh_init cl_init msubst top cl in let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in (inh_init, transl_vals cla true false vals cl_init) | Tclass_apply (cl, exprs) -> - build_class_init cla pub_meths cstr inh_init cl_init msubst top cl + build_class_init cla cstr inh_init cl_init msubst top cl | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, cl_init) = - build_class_init cla pub_meths cstr inh_init cl_init msubst top cl + build_class_init cla cstr inh_init cl_init msubst top cl in let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in (inh_init, transl_vals cla true false vals cl_init) @@ -339,7 +347,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl = cl_init)) | _ -> let core cl_init = - build_class_init cla pub_meths true inh_init cl_init msubst top cl + build_class_init cla true inh_init cl_init msubst top cl in if cstr then core cl_init else let (inh_init, cl_init) = @@ -463,8 +471,8 @@ let rec builtin_meths self env env2 body = "var", [Lvar n] | Lprim(Pfield n, [Lvar e]) when Ident.same e env -> "env", [Lvar env2; Lconst(Const_pointer n)] - | Lsend(Lvar n, Lvar s, []) when List.mem s self -> - "meth", [Lvar n] + | Lsend(Self, met, Lvar s, []) when List.mem s self -> + "meth", [met] | _ -> raise Not_found in match body with @@ -478,14 +486,17 @@ let rec builtin_meths self env env2 body = | Lapply(f, [p; arg]) when const_path f && const_path p -> let s, args = conv arg in ("app_const_"^s, f :: p :: args) - | Lsend(Lvar n, Lvar s, [arg]) when List.mem s self -> + | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self -> let s, args = conv arg in ("meth_app_"^s, Lvar n :: args) - | Lsend(Lvar n, Lvar s, []) when List.mem s self -> - ("get_meth", [Lvar n]) - | Lsend(Lvar n, arg, []) -> + | Lsend(Self, met, Lvar s, []) when List.mem s self -> + ("get_meth", [met]) + | Lsend(Public, met, arg, []) -> + let s, args = conv arg in + ("send_"^s, met :: args) + | Lsend(Cached, met, arg, [_;_]) -> let s, args = conv arg in - ("send_"^s, Lvar n :: args) + ("send_"^s, met :: args) | Lfunction (Curried, [x], body) -> let rec enter self = function | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x']) @@ -621,14 +632,24 @@ let transl_class ids cl_id arity pub_meths cl = if not (Translcore.check_recursive_lambda ids obj_init) then raise(Error(cl.cl_loc, Illegal_class_expr)); let (inh_init', cl_init) = - build_class_init cla pub_meths true (List.rev inh_init) - obj_init msubst top cl + build_class_init cla true (List.rev inh_init) obj_init msubst top cl in assert (inh_init' = []); let table = Ident.create "table" - and class_init = Ident.create "class_init" + and class_init = Ident.create (Ident.name cl_id ^ "_init") and env_init = Ident.create "env_init" and obj_init = Ident.create "obj_init" in + let pub_meths = + List.sort + (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) + pub_meths in + let tags = List.map Btype.hash_variant pub_meths in + let rev_map = List.combine tags pub_meths in + List.iter2 + (fun tag name -> + let name' = List.assoc tag rev_map in + if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) + tags pub_meths; let ltable table lam = Llet(Strict, table, Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam) @@ -764,3 +785,6 @@ open Format let report_error ppf = function | Illegal_class_expr -> fprintf ppf "This kind of class expression is not allowed" + | Tags (lab1, lab2) -> + fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" + lab1 lab2 "Change one of them." |