summaryrefslogtreecommitdiff
path: root/bytecomp/translclass.ml
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp/translclass.ml')
-rw-r--r--bytecomp/translclass.ml113
1 files changed, 77 insertions, 36 deletions
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index f0109dae31..59153bd677 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
@@ -103,15 +103,18 @@ let transl_super tbl meths inh_methods rem =
let create_object cl obj init =
let obj' = Ident.create "self" in
- let (inh_init, obj_init) = init obj' in
+ let (inh_init, obj_init, has_init) = init obj' in
if obj_init = lambda_unit then
- (inh_init,
- Lapply (oo_prim "create_object_and_run_initializers", [obj; Lvar cl]))
+ (inh_init,
+ Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
+ else"create_object_opt"),
+ [obj; Lvar cl]))
else begin
(inh_init,
Llet(Strict, obj',
Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
Lsequence(obj_init,
+ if not has_init then Lvar obj' else
Lapply (oo_prim "run_initializers_opt",
[obj; Lvar obj'; Lvar cl]))))
end
@@ -129,20 +132,23 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
Lapply(Lvar obj_init, env @ [obj]))
| Tclass_structure str ->
create_object cl_table obj (fun obj ->
- let (inh_init, obj_init) =
+ let (inh_init, obj_init, has_init) =
List.fold_right
- (fun field (inh_init, obj_init) ->
+ (fun field (inh_init, obj_init, has_init) ->
match field with
Cf_inher (cl, _, _) ->
let (inh_init, obj_init') =
build_object_init cl_table (Lvar obj) [] inh_init
(fun _ -> lambda_unit) cl
in
- (inh_init, lsequence obj_init' obj_init)
+ (inh_init, lsequence obj_init' obj_init, true)
| Cf_val (_, id, exp) ->
- (inh_init, lsequence (set_inst_var obj id exp) obj_init)
- | Cf_meth _ | Cf_init _ ->
- (inh_init, obj_init)
+ (inh_init, lsequence (set_inst_var obj id exp) obj_init,
+ has_init)
+ | Cf_meth _ ->
+ (inh_init, obj_init, has_init)
+ | Cf_init _ ->
+ (inh_init, obj_init, true)
| Cf_let (rec_flag, defs, vals) ->
(inh_init,
Translcore.transl_let rec_flag defs
@@ -150,15 +156,17 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
(fun (id, expr) rem ->
lsequence (Lifused(id, set_inst_var obj id expr))
rem)
- vals obj_init)))
+ vals obj_init),
+ has_init))
str.cl_field
- (inh_init, obj_init obj)
+ (inh_init, obj_init obj, false)
in
(inh_init,
List.fold_right
(fun (id, expr) rem ->
lsequence (Lifused (id, set_inst_var obj id expr)) rem)
- params obj_init))
+ params obj_init,
+ has_init))
| Tclass_fun (pat, vals, cl, partial) ->
let (inh_init, obj_init) =
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
@@ -203,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 =
@@ -233,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
@@ -255,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
@@ -296,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)
@@ -331,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) =
@@ -455,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
@@ -470,9 +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(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, met :: args)
| Lfunction (Curried, [x], body) ->
let rec enter self = function
| Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
@@ -512,6 +536,10 @@ module M = struct
| "meth_app_var" -> MethAppVar
| "meth_app_env" -> MethAppEnv
| "meth_app_meth" -> MethAppMeth
+ | "send_const" -> SendConst
+ | "send_var" -> SendVar
+ | "send_env" -> SendEnv
+ | "send_meth" -> SendMeth
| _ -> assert false
in Lconst(Const_pointer(Obj.magic tag)) :: args
end
@@ -604,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)
@@ -747,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."
View Lorry Controller Status