fast and compact classes
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5977 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
e32f8e9858
commit
f2095623ff
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -27,6 +27,7 @@ type error = Illegal_class_expr
|
||||||
exception Error of Location.t * error
|
exception Error of Location.t * error
|
||||||
|
|
||||||
let lfunction params body =
|
let lfunction params body =
|
||||||
|
if params = [] then body else
|
||||||
match body with
|
match body with
|
||||||
Lfunction (Curried, params', body') ->
|
Lfunction (Curried, params', body') ->
|
||||||
Lfunction (Curried, params @ params', body')
|
Lfunction (Curried, params @ params', body')
|
||||||
|
@ -43,13 +44,14 @@ let lapply func args =
|
||||||
let lsequence l1 l2 =
|
let lsequence l1 l2 =
|
||||||
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
|
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
|
||||||
|
|
||||||
let transl_label l = Lconst (Const_base (Const_string l))
|
let lfield v i = Lprim(Pfield i, [Lvar v])
|
||||||
|
|
||||||
|
let transl_label l = share (Const_base (Const_string l))
|
||||||
|
|
||||||
let rec transl_meth_list lst =
|
let rec transl_meth_list lst =
|
||||||
Lconst
|
if lst = [] then Lconst (Const_pointer 0) else
|
||||||
(List.fold_right
|
share (Const_block
|
||||||
(fun lab rem -> Const_block (0, [Const_base (Const_string lab); rem]))
|
(0, List.map (fun lab -> Const_base (Const_string lab)) lst))
|
||||||
lst (Const_pointer 0))
|
|
||||||
|
|
||||||
let set_inst_var obj id expr =
|
let set_inst_var obj id expr =
|
||||||
let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
|
let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
|
||||||
|
@ -65,15 +67,26 @@ let copy_inst_var obj id expr templ offset =
|
||||||
[Lvar id';
|
[Lvar id';
|
||||||
Lvar offset])])]))
|
Lvar offset])])]))
|
||||||
|
|
||||||
let transl_val tbl create name id rem =
|
let transl_val tbl create name =
|
||||||
Llet(StrictOpt, id, Lapply (oo_prim (if create then "new_variable"
|
Lapply (oo_prim (if create then "new_variable" else "get_variable"),
|
||||||
else "get_variable"),
|
[Lvar tbl; transl_label name])
|
||||||
[Lvar tbl; transl_label name]),
|
|
||||||
rem)
|
|
||||||
|
|
||||||
let transl_vals tbl create vals rem =
|
let transl_vals tbl create sure vals rem =
|
||||||
|
if create && sure && List.length vals > 1 then
|
||||||
|
let (_,id0) = List.hd vals in
|
||||||
|
let call =
|
||||||
|
Lapply(oo_prim "new_variables",
|
||||||
|
[Lvar tbl; transl_meth_list (List.map fst vals)]) in
|
||||||
|
let i = ref (List.length vals) in
|
||||||
|
Llet(Strict, id0, call,
|
||||||
|
List.fold_right
|
||||||
|
(fun (name,id) rem ->
|
||||||
|
decr i; Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
|
||||||
|
(List.tl vals) rem)
|
||||||
|
else
|
||||||
List.fold_right
|
List.fold_right
|
||||||
(fun (name, id) rem -> transl_val tbl create name id rem)
|
(fun (name, id) rem ->
|
||||||
|
Llet(StrictOpt, id, transl_val tbl create name, rem))
|
||||||
vals rem
|
vals rem
|
||||||
|
|
||||||
let transl_super tbl meths inh_methods rem =
|
let transl_super tbl meths inh_methods rem =
|
||||||
|
@ -93,22 +106,27 @@ let create_object cl obj init =
|
||||||
let (inh_init, obj_init) = init obj' in
|
let (inh_init, obj_init) = init obj' in
|
||||||
if obj_init = lambda_unit then
|
if obj_init = lambda_unit then
|
||||||
(inh_init,
|
(inh_init,
|
||||||
Lapply (oo_prim "create_object_and_run_initializers",
|
Lapply (oo_prim "create_object_and_run_initializers", [obj; Lvar cl]))
|
||||||
[Lvar obj; Lvar cl]))
|
|
||||||
else begin
|
else begin
|
||||||
(inh_init,
|
(inh_init,
|
||||||
Llet(Strict, obj',
|
Llet(Strict, obj',
|
||||||
Lapply (oo_prim "create_object_opt", [Lvar obj; Lvar cl]),
|
Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
|
||||||
Lsequence(obj_init,
|
Lsequence(obj_init,
|
||||||
Lapply (oo_prim "run_initializers_opt",
|
Lapply (oo_prim "run_initializers_opt",
|
||||||
[Lvar obj; Lvar obj'; Lvar cl]))))
|
[obj; Lvar obj'; Lvar cl]))))
|
||||||
end
|
end
|
||||||
|
|
||||||
let rec build_object_init cl_table obj params inh_init cl =
|
let rec build_object_init cl_table obj params inh_init obj_init cl =
|
||||||
match cl.cl_desc with
|
match cl.cl_desc with
|
||||||
Tclass_ident path ->
|
Tclass_ident path ->
|
||||||
let obj_init = Ident.create "obj_init" in
|
let obj_init = Ident.create "obj_init" in
|
||||||
(obj_init::inh_init, Lapply(Lvar obj_init, [Lvar obj]))
|
let envs, inh_init = inh_init in
|
||||||
|
let env =
|
||||||
|
match envs with None -> []
|
||||||
|
| Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
|
||||||
|
in
|
||||||
|
((envs, (obj_init, path)::inh_init),
|
||||||
|
Lapply(Lvar obj_init, env @ [obj]))
|
||||||
| Tclass_structure str ->
|
| Tclass_structure str ->
|
||||||
create_object cl_table obj (fun obj ->
|
create_object cl_table obj (fun obj ->
|
||||||
let (inh_init, obj_init) =
|
let (inh_init, obj_init) =
|
||||||
|
@ -117,7 +135,8 @@ let rec build_object_init cl_table obj params inh_init cl =
|
||||||
match field with
|
match field with
|
||||||
Cf_inher (cl, _, _) ->
|
Cf_inher (cl, _, _) ->
|
||||||
let (inh_init, obj_init') =
|
let (inh_init, obj_init') =
|
||||||
build_object_init cl_table obj [] inh_init cl
|
build_object_init cl_table (Lvar obj) [] inh_init
|
||||||
|
(fun _ -> lambda_unit) cl
|
||||||
in
|
in
|
||||||
(inh_init, lsequence obj_init' obj_init)
|
(inh_init, lsequence obj_init' obj_init)
|
||||||
| Cf_val (_, id, exp) ->
|
| Cf_val (_, id, exp) ->
|
||||||
|
@ -133,7 +152,7 @@ let rec build_object_init cl_table obj params inh_init cl =
|
||||||
rem)
|
rem)
|
||||||
vals obj_init)))
|
vals obj_init)))
|
||||||
str.cl_field
|
str.cl_field
|
||||||
(inh_init, lambda_unit)
|
(inh_init, obj_init obj)
|
||||||
in
|
in
|
||||||
(inh_init,
|
(inh_init,
|
||||||
List.fold_right
|
List.fold_right
|
||||||
|
@ -142,7 +161,7 @@ let rec build_object_init cl_table obj params inh_init cl =
|
||||||
params obj_init))
|
params obj_init))
|
||||||
| Tclass_fun (pat, vals, cl, partial) ->
|
| Tclass_fun (pat, vals, cl, partial) ->
|
||||||
let (inh_init, obj_init) =
|
let (inh_init, obj_init) =
|
||||||
build_object_init cl_table obj (vals @ params) inh_init cl
|
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
|
||||||
in
|
in
|
||||||
(inh_init,
|
(inh_init,
|
||||||
let build params rem =
|
let build params rem =
|
||||||
|
@ -157,29 +176,32 @@ let rec build_object_init cl_table obj params inh_init cl =
|
||||||
end)
|
end)
|
||||||
| Tclass_apply (cl, oexprs) ->
|
| Tclass_apply (cl, oexprs) ->
|
||||||
let (inh_init, obj_init) =
|
let (inh_init, obj_init) =
|
||||||
build_object_init cl_table obj params inh_init cl
|
build_object_init cl_table obj params inh_init obj_init cl
|
||||||
in
|
in
|
||||||
(inh_init, transl_apply obj_init oexprs)
|
(inh_init, transl_apply obj_init oexprs)
|
||||||
| Tclass_let (rec_flag, defs, vals, cl) ->
|
| Tclass_let (rec_flag, defs, vals, cl) ->
|
||||||
let (inh_init, obj_init) =
|
let (inh_init, obj_init) =
|
||||||
build_object_init cl_table obj (vals @ params) inh_init cl
|
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
|
||||||
in
|
in
|
||||||
(inh_init, Translcore.transl_let rec_flag defs obj_init)
|
(inh_init, Translcore.transl_let rec_flag defs obj_init)
|
||||||
| Tclass_constraint (cl, vals, pub_meths, concr_meths) ->
|
| Tclass_constraint (cl, vals, pub_meths, concr_meths) ->
|
||||||
build_object_init cl_table obj params inh_init cl
|
build_object_init cl_table obj params inh_init obj_init cl
|
||||||
|
|
||||||
let rec build_object_init_0 cl_table params cl =
|
let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
|
||||||
match cl.cl_desc with
|
match cl.cl_desc with
|
||||||
Tclass_let (rec_flag, defs, vals, cl) ->
|
Tclass_let (rec_flag, defs, vals, cl) ->
|
||||||
let (inh_init, obj_init) =
|
build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
|
||||||
build_object_init_0 cl_table (vals @ params) cl
|
|
||||||
in
|
|
||||||
(inh_init, Translcore.transl_let rec_flag defs obj_init)
|
|
||||||
| _ ->
|
| _ ->
|
||||||
let obj = Ident.create "self" in
|
let self = Ident.create "self" in
|
||||||
let (inh_init, obj_init) = build_object_init cl_table obj params [] cl in
|
let env = Ident.create "env" in
|
||||||
let obj_init = lfunction [obj] obj_init in
|
let obj = if ids = [] then lambda_unit else Lvar self in
|
||||||
(inh_init, obj_init)
|
let envs = if top then None else Some env in
|
||||||
|
let ((_,inh_init), obj_init) =
|
||||||
|
build_object_init cl_table obj params (envs,[]) (copy_env env) cl in
|
||||||
|
let obj_init =
|
||||||
|
if ids = [] then obj_init else lfunction [self] obj_init in
|
||||||
|
(inh_init, lfunction [env] (subst_env env obj_init))
|
||||||
|
|
||||||
|
|
||||||
let bind_method tbl public_methods lab id cl_init =
|
let bind_method tbl public_methods lab id cl_init =
|
||||||
if List.mem lab public_methods then
|
if List.mem lab public_methods then
|
||||||
|
@ -192,138 +214,504 @@ let bind_method tbl public_methods lab id cl_init =
|
||||||
let bind_methods tbl public_methods meths cl_init =
|
let bind_methods tbl public_methods meths cl_init =
|
||||||
Meths.fold (bind_method tbl public_methods) meths cl_init
|
Meths.fold (bind_method tbl public_methods) meths cl_init
|
||||||
|
|
||||||
let rec build_class_init cla pub_meths cstr inh_init cl_init cl =
|
let output_methods tbl vals methods lam =
|
||||||
|
let lam =
|
||||||
|
match methods with
|
||||||
|
[] -> lam
|
||||||
|
| [lab; code] ->
|
||||||
|
lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
|
||||||
|
| _ ->
|
||||||
|
lsequence (Lapply(oo_prim "set_methods",
|
||||||
|
[Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
|
||||||
|
lam
|
||||||
|
in
|
||||||
|
transl_vals tbl true true vals lam
|
||||||
|
|
||||||
|
let rec ignore_cstrs cl =
|
||||||
|
match cl.cl_desc with
|
||||||
|
Tclass_constraint (cl, _, _, _) -> 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 =
|
||||||
match cl.cl_desc with
|
match cl.cl_desc with
|
||||||
Tclass_ident path ->
|
Tclass_ident path ->
|
||||||
begin match inh_init with
|
begin match inh_init with
|
||||||
obj_init::inh_init ->
|
(obj_init, path')::inh_init ->
|
||||||
|
let lpath = transl_path path in
|
||||||
(inh_init,
|
(inh_init,
|
||||||
Llet (Strict, obj_init,
|
Llet (Strict, obj_init,
|
||||||
Lapply(Lprim(Pfield 1, [transl_path path]), [Lvar cla]),
|
Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
|
||||||
|
if top then [Lprim(Pfield 3, [lpath])] else []),
|
||||||
cl_init))
|
cl_init))
|
||||||
| _ ->
|
| _ ->
|
||||||
assert false
|
assert false
|
||||||
end
|
end
|
||||||
| Tclass_structure str ->
|
| Tclass_structure str ->
|
||||||
let (inh_init, cl_init) =
|
let (inh_init, cl_init, methods, values) =
|
||||||
List.fold_right
|
List.fold_right
|
||||||
(fun field (inh_init, cl_init) ->
|
(fun field (inh_init, cl_init, methods, values) ->
|
||||||
match field with
|
match field with
|
||||||
Cf_inher (cl, vals, meths) ->
|
Cf_inher (cl, vals, meths) ->
|
||||||
build_class_init cla pub_meths false inh_init
|
let cl_init = output_methods cla values methods cl_init in
|
||||||
(transl_vals cla false vals
|
let inh_init, cl_init =
|
||||||
(transl_super cla str.cl_meths meths cl_init))
|
build_class_init cla pub_meths false inh_init
|
||||||
cl
|
(transl_vals cla false false vals
|
||||||
|
(transl_super cla str.cl_meths meths cl_init))
|
||||||
|
msubst top cl in
|
||||||
|
(inh_init, cl_init, [], [])
|
||||||
| Cf_val (name, id, exp) ->
|
| Cf_val (name, id, exp) ->
|
||||||
(inh_init, transl_val cla true name id cl_init)
|
(inh_init, cl_init, methods, (name, id)::values)
|
||||||
| Cf_meth (name, exp) ->
|
| Cf_meth (name, exp) ->
|
||||||
|
let met_code = msubst true (transl_exp exp) in
|
||||||
let met_code =
|
let met_code =
|
||||||
if !Clflags.native_code then begin
|
if !Clflags.native_code && List.length met_code = 1 then
|
||||||
(* Force correct naming of method for profiles *)
|
(* Force correct naming of method for profiles *)
|
||||||
let met = Ident.create ("method_" ^ name) in
|
let met = Ident.create ("method_" ^ name) in
|
||||||
Llet(Strict, met, transl_exp exp, Lvar met)
|
[Llet(Strict, met, List.hd met_code, Lvar met)]
|
||||||
end else
|
else met_code
|
||||||
transl_exp exp in
|
in
|
||||||
(inh_init,
|
(inh_init, cl_init,
|
||||||
Lsequence(Lapply (oo_prim "set_method",
|
Lvar (Meths.find name str.cl_meths) :: met_code @ methods,
|
||||||
[Lvar cla;
|
values)
|
||||||
Lvar (Meths.find name str.cl_meths);
|
(*
|
||||||
met_code]),
|
Lsequence(Lapply (oo_prim ("set_method" ^ builtin),
|
||||||
|
Lvar cla ::
|
||||||
|
Lvar (Meths.find name str.cl_meths) ::
|
||||||
|
met_code),
|
||||||
cl_init))
|
cl_init))
|
||||||
|
*)
|
||||||
| Cf_let (rec_flag, defs, vals) ->
|
| Cf_let (rec_flag, defs, vals) ->
|
||||||
let vals =
|
let vals =
|
||||||
List.map (function (id, _) -> (Ident.name id, id)) vals
|
List.map (function (id, _) -> (Ident.name id, id)) vals
|
||||||
in
|
in
|
||||||
(inh_init, transl_vals cla true vals cl_init)
|
(inh_init, cl_init, methods, vals @ values)
|
||||||
| Cf_init exp ->
|
| Cf_init exp ->
|
||||||
(inh_init,
|
(inh_init,
|
||||||
Lsequence(Lapply (oo_prim "add_initializer",
|
Lsequence(Lapply (oo_prim "add_initializer",
|
||||||
[Lvar cla; transl_exp exp]),
|
Lvar cla :: msubst false (transl_exp exp)),
|
||||||
cl_init)))
|
cl_init),
|
||||||
|
methods, values))
|
||||||
str.cl_field
|
str.cl_field
|
||||||
(inh_init, cl_init)
|
(inh_init, cl_init, [], [])
|
||||||
in
|
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 pub_meths str.cl_meths cl_init)
|
||||||
| Tclass_fun (pat, vals, cl, _) ->
|
| Tclass_fun (pat, vals, cl, _) ->
|
||||||
let (inh_init, cl_init) =
|
let (inh_init, cl_init) =
|
||||||
build_class_init cla pub_meths cstr inh_init cl_init cl
|
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
|
||||||
in
|
in
|
||||||
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
|
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
|
||||||
(inh_init, transl_vals cla true vals cl_init)
|
(inh_init, transl_vals cla true false vals cl_init)
|
||||||
| Tclass_apply (cl, exprs) ->
|
| Tclass_apply (cl, exprs) ->
|
||||||
build_class_init cla pub_meths cstr inh_init cl_init cl
|
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
|
||||||
| Tclass_let (rec_flag, defs, vals, cl) ->
|
| Tclass_let (rec_flag, defs, vals, cl) ->
|
||||||
let (inh_init, cl_init) =
|
let (inh_init, cl_init) =
|
||||||
build_class_init cla pub_meths cstr inh_init cl_init cl
|
build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
|
||||||
in
|
in
|
||||||
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
|
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
|
||||||
(inh_init, transl_vals cla true vals cl_init)
|
(inh_init, transl_vals cla true false vals cl_init)
|
||||||
| Tclass_constraint (cl, vals, meths, concr_meths) ->
|
| Tclass_constraint (cl, vals, meths, concr_meths) ->
|
||||||
let core cl_init =
|
let virt_meths =
|
||||||
build_class_init cla pub_meths true inh_init cl_init cl
|
List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
|
||||||
in
|
let narrow_args =
|
||||||
if cstr then
|
[Lvar cla;
|
||||||
core cl_init
|
transl_meth_list vals;
|
||||||
else
|
transl_meth_list virt_meths;
|
||||||
let virt_meths =
|
transl_meth_list (Concr.elements concr_meths)] in
|
||||||
List.fold_right
|
let cl = ignore_cstrs cl in
|
||||||
(fun lab rem ->
|
begin match cl.cl_desc, inh_init with
|
||||||
if Concr.mem lab concr_meths then rem else lab::rem)
|
Tclass_ident path, (obj_init, path')::inh_init ->
|
||||||
meths
|
assert (Path.same path path');
|
||||||
[]
|
let lpath = transl_path path in
|
||||||
in
|
(inh_init,
|
||||||
let (inh_init, cl_init) =
|
Llet (Strict, obj_init,
|
||||||
core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]),
|
Lapply(oo_prim "inherits", narrow_args @
|
||||||
cl_init))
|
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
|
||||||
in
|
cl_init))
|
||||||
(inh_init,
|
| _ ->
|
||||||
Lsequence(Lapply (oo_prim "narrow",
|
let core cl_init =
|
||||||
[Lvar cla;
|
build_class_init cla pub_meths true inh_init cl_init msubst top cl
|
||||||
transl_meth_list vals;
|
in
|
||||||
transl_meth_list virt_meths;
|
if cstr then core cl_init else
|
||||||
transl_meth_list (Concr.elements concr_meths)]),
|
let (inh_init, cl_init) =
|
||||||
cl_init))
|
core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
|
||||||
|
in
|
||||||
|
(inh_init,
|
||||||
|
Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
|
||||||
|
end
|
||||||
|
|
||||||
|
let rec build_class_lets cl =
|
||||||
|
match cl.cl_desc with
|
||||||
|
Tclass_let (rec_flag, defs, vals, cl) ->
|
||||||
|
let env, wrap = build_class_lets cl in
|
||||||
|
(env, fun x -> Translcore.transl_let rec_flag defs (wrap x))
|
||||||
|
| _ ->
|
||||||
|
(cl.cl_env, fun x -> x)
|
||||||
|
|
||||||
(*
|
(*
|
||||||
XXX Il devrait etre peu couteux d'ecrire des classes :
|
XXX Il devrait etre peu couteux d'ecrire des classes :
|
||||||
class c x y = d e f
|
class c x y = d e f
|
||||||
*)
|
*)
|
||||||
|
let rec transl_class_rebind obj_init cl =
|
||||||
|
match cl.cl_desc with
|
||||||
|
Tclass_ident path ->
|
||||||
|
(path, obj_init)
|
||||||
|
| Tclass_fun (pat, _, cl, partial) ->
|
||||||
|
let path, obj_init = transl_class_rebind obj_init cl in
|
||||||
|
let build params rem =
|
||||||
|
let param = name_pattern "param" [pat, ()] in
|
||||||
|
Lfunction (Curried, param::params,
|
||||||
|
Matching.for_function
|
||||||
|
pat.pat_loc None (Lvar param) [pat, rem] partial)
|
||||||
|
in
|
||||||
|
(path,
|
||||||
|
match obj_init with
|
||||||
|
Lfunction (Curried, params, rem) -> build params rem
|
||||||
|
| rem -> build [] rem)
|
||||||
|
| Tclass_apply (cl, oexprs) ->
|
||||||
|
let path, obj_init = transl_class_rebind obj_init cl in
|
||||||
|
(path, transl_apply obj_init oexprs)
|
||||||
|
| Tclass_let (rec_flag, defs, vals, cl) ->
|
||||||
|
let path, obj_init = transl_class_rebind obj_init cl in
|
||||||
|
(path, Translcore.transl_let rec_flag defs obj_init)
|
||||||
|
| Tclass_structure {cl_field = [Cf_inher(cl, _, _)]} ->
|
||||||
|
let path, obj_init = transl_class_rebind obj_init cl in
|
||||||
|
(path, obj_init)
|
||||||
|
| Tclass_structure _ -> raise Exit
|
||||||
|
| Tclass_constraint (cl', _, _, _) ->
|
||||||
|
let path, obj_init = transl_class_rebind obj_init cl' in
|
||||||
|
let rec check_constraint = function
|
||||||
|
Tcty_constr(path', _, _) when Path.same path path' -> ()
|
||||||
|
| Tcty_fun (_, _, cty) -> check_constraint cty
|
||||||
|
| _ -> raise Exit
|
||||||
|
in
|
||||||
|
check_constraint cl.cl_type;
|
||||||
|
(path, obj_init)
|
||||||
|
|
||||||
|
let rec transl_class_rebind_0 self obj_init cl =
|
||||||
|
match cl.cl_desc with
|
||||||
|
Tclass_let (rec_flag, defs, vals, cl) ->
|
||||||
|
let path, obj_init = transl_class_rebind_0 self obj_init cl in
|
||||||
|
(path, Translcore.transl_let rec_flag defs obj_init)
|
||||||
|
| _ ->
|
||||||
|
let path, obj_init = transl_class_rebind obj_init cl in
|
||||||
|
(path, lfunction [self] obj_init)
|
||||||
|
|
||||||
|
let transl_class_rebind ids cl =
|
||||||
|
try
|
||||||
|
let obj_init = Ident.create "obj_init"
|
||||||
|
and self = Ident.create "self" in
|
||||||
|
let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
|
||||||
|
let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
|
||||||
|
if not (Translcore.check_recursive_lambda ids obj_init') then
|
||||||
|
raise(Error(cl.cl_loc, Illegal_class_expr));
|
||||||
|
let id = (obj_init' = lfunction [self] obj_init0) in
|
||||||
|
if id then transl_path path else
|
||||||
|
|
||||||
|
let cla = Ident.create "class"
|
||||||
|
and new_init = Ident.create "new_init"
|
||||||
|
and arg = Ident.create "arg"
|
||||||
|
and env_init = Ident.create "env_init"
|
||||||
|
and table = Ident.create "table"
|
||||||
|
and envs = Ident.create "envs" in
|
||||||
|
Llet(
|
||||||
|
Strict, new_init, lfunction [obj_init] obj_init',
|
||||||
|
Llet(
|
||||||
|
Alias, cla, transl_path path,
|
||||||
|
Lprim(Pmakeblock(0, Immutable),
|
||||||
|
[Lapply(Lvar new_init, [lfield cla 0]);
|
||||||
|
lfunction [table]
|
||||||
|
(Llet(Strict, env_init,
|
||||||
|
Lapply(lfield cla 1, [Lvar table]),
|
||||||
|
lfunction [envs]
|
||||||
|
(Lapply(Lvar new_init,
|
||||||
|
[Lapply(Lvar env_init, [Lvar envs])]))));
|
||||||
|
lfield cla 2;
|
||||||
|
lfield cla 3])))
|
||||||
|
with Exit ->
|
||||||
|
lambda_unit
|
||||||
|
|
||||||
|
(* Rewrite a closure using builtins. Improves native code size. *)
|
||||||
|
|
||||||
|
let rec module_path = function
|
||||||
|
Lvar id ->
|
||||||
|
let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
|
||||||
|
| Lprim(Pfield _, [p]) -> module_path p
|
||||||
|
| Lprim(Pgetglobal _, []) -> true
|
||||||
|
| _ -> false
|
||||||
|
|
||||||
|
let const_path local = function
|
||||||
|
Lvar id -> not (List.mem id local)
|
||||||
|
| Lconst _ -> true
|
||||||
|
| Lfunction (Curried, _, body) ->
|
||||||
|
let fv = free_variables body in
|
||||||
|
List.for_all (fun x -> not (IdentSet.mem x fv)) local
|
||||||
|
| p -> module_path p
|
||||||
|
|
||||||
|
let rec builtin_meths self env env2 body =
|
||||||
|
let const_path = const_path (env::self) in
|
||||||
|
let conv = function
|
||||||
|
(* Lvar s when List.mem s self -> "_self", [] *)
|
||||||
|
| p when const_path p -> "const", [p]
|
||||||
|
| Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self ->
|
||||||
|
"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]
|
||||||
|
| _ -> raise Not_found
|
||||||
|
in
|
||||||
|
match body with
|
||||||
|
| Llet(Alias, s', Lvar s, body) when List.mem s self ->
|
||||||
|
builtin_meths self env env2 body
|
||||||
|
| Lapply(f, [arg]) when const_path f ->
|
||||||
|
let s, args = conv arg in ("app_"^s, f :: args)
|
||||||
|
| Lapply(f, [arg; p]) when const_path f && const_path p ->
|
||||||
|
let s, args = conv arg in
|
||||||
|
("app_"^s^"_const", f :: args @ [p])
|
||||||
|
| 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 ->
|
||||||
|
let s, args = conv arg in
|
||||||
|
("meth_app_"^s, Lvar n :: args)
|
||||||
|
| Lfunction (Curried, [x], body) ->
|
||||||
|
let rec enter self = function
|
||||||
|
| Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
|
||||||
|
when Ident.same x x' && List.mem s self ->
|
||||||
|
("set_var", [Lvar n])
|
||||||
|
| Llet(Alias, s', Lvar s, body) when List.mem s self ->
|
||||||
|
enter (s'::self) body
|
||||||
|
| _ -> raise Not_found
|
||||||
|
in enter self body
|
||||||
|
| Lfunction _ -> raise Not_found
|
||||||
|
| _ ->
|
||||||
|
let s, args = conv body in ("get_"^s, args)
|
||||||
|
|
||||||
|
module M = struct
|
||||||
|
open CamlinternalOO
|
||||||
|
let builtin_meths arr self env env2 body =
|
||||||
|
let builtin, args = builtin_meths self env env2 body in
|
||||||
|
if not arr then [Lapply(oo_prim builtin, args)] else
|
||||||
|
let tag = match builtin with
|
||||||
|
"get_const" -> GetConst
|
||||||
|
| "get_var" -> GetVar
|
||||||
|
| "get_env" -> GetEnv
|
||||||
|
| "get_meth" -> GetMeth
|
||||||
|
| "set_var" -> SetVar
|
||||||
|
| "app_const" -> AppConst
|
||||||
|
| "app_var" -> AppVar
|
||||||
|
| "app_env" -> AppEnv
|
||||||
|
| "app_meth" -> AppMeth
|
||||||
|
| "app_const_const" -> AppConstConst
|
||||||
|
| "app_const_var" -> AppConstVar
|
||||||
|
| "app_const_env" -> AppConstEnv
|
||||||
|
| "app_const_meth" -> AppConstMeth
|
||||||
|
| "app_var_const" -> AppVarConst
|
||||||
|
| "app_env_const" -> AppEnvConst
|
||||||
|
| "app_meth_const" -> AppMethConst
|
||||||
|
| "meth_app_const" -> MethAppConst
|
||||||
|
| "meth_app_var" -> MethAppVar
|
||||||
|
| "meth_app_env" -> MethAppEnv
|
||||||
|
| "meth_app_meth" -> MethAppMeth
|
||||||
|
| _ -> assert false
|
||||||
|
in Lconst(Const_pointer(Obj.magic tag)) :: args
|
||||||
|
end
|
||||||
|
open M
|
||||||
|
|
||||||
|
|
||||||
(*
|
(*
|
||||||
XXX
|
Traduction d'une classe.
|
||||||
Exploiter le fait que les methodes sont definies dans l'ordre pour
|
Plusieurs cas:
|
||||||
l'initialisation des classes (et les variables liees par un
|
* reapplication d'une classe connue -> transl_class_rebind
|
||||||
let ???) ?
|
* classe sans dependances locales -> traduction directe
|
||||||
|
* avec dependances locale -> creation d'un arbre de stubs,
|
||||||
|
avec un noeud pour chaque classe locale heritee
|
||||||
|
Une classe est un 4-uplet:
|
||||||
|
(obj_init, class_init, env_init, env)
|
||||||
|
obj_init: fonction de creation d'objet (unit -> obj)
|
||||||
|
class_init: fonction d'heritage (table -> env_init)
|
||||||
|
(une seule par code source)
|
||||||
|
env_init: parametrage par l'environnement local (env -> params -> obj_init)
|
||||||
|
(une par combinaison d'env_init herites)
|
||||||
|
env: environnement local
|
||||||
|
Si ids=0 (objet immediat), alors on ne conserve que env_init.
|
||||||
*)
|
*)
|
||||||
|
|
||||||
|
|
||||||
let transl_class ids cl_id arity pub_meths cl =
|
let transl_class ids cl_id arity pub_meths cl =
|
||||||
|
(* First check if it is not only a rebind *)
|
||||||
|
let rebind = transl_class_rebind ids cl in
|
||||||
|
if rebind <> lambda_unit then rebind else
|
||||||
|
|
||||||
|
(* Prepare for heavy environment handling *)
|
||||||
|
let tables = Ident.create (Ident.name cl_id ^ "_tables") in
|
||||||
|
let (top_env, req) = oo_add_class tables in
|
||||||
|
let top = not req in
|
||||||
|
let cl_env, llets = build_class_lets cl in
|
||||||
|
let new_ids = if top then [] else Env.diff top_env cl_env in
|
||||||
|
let env2 = Ident.create "env" in
|
||||||
|
let subst env lam i0 new_ids' =
|
||||||
|
let fv = free_variables lam in
|
||||||
|
let fv = List.fold_right IdentSet.remove !new_ids' fv in
|
||||||
|
let fv =
|
||||||
|
IdentSet.filter (fun id -> List.mem id new_ids) fv in
|
||||||
|
new_ids' := !new_ids' @ IdentSet.elements fv;
|
||||||
|
let i = ref (i0-1) in
|
||||||
|
List.fold_left
|
||||||
|
(fun subst id ->
|
||||||
|
incr i; Ident.add id (lfield env !i) subst)
|
||||||
|
Ident.empty !new_ids'
|
||||||
|
in
|
||||||
|
let new_ids_meths = ref [] in
|
||||||
|
let msubst arr = function
|
||||||
|
Lfunction (Curried, self :: args, body) ->
|
||||||
|
let env = Ident.create "env" in
|
||||||
|
let body' =
|
||||||
|
if new_ids = [] then body else
|
||||||
|
subst_lambda (subst env body 0 new_ids_meths) body in
|
||||||
|
begin try
|
||||||
|
(* Doesn't seem to improve size for bytecode *)
|
||||||
|
(* if not !Clflags.native_code then raise Not_found; *)
|
||||||
|
builtin_meths arr [self] env env2 (lfunction args body')
|
||||||
|
with Not_found ->
|
||||||
|
[lfunction (self :: args)
|
||||||
|
(if not (IdentSet.mem env (free_variables body')) then body' else
|
||||||
|
Llet(Alias, env,
|
||||||
|
Lprim(Parrayrefu Paddrarray,
|
||||||
|
[Lvar self; Lvar env2]), body'))]
|
||||||
|
end
|
||||||
|
| _ -> assert false
|
||||||
|
in
|
||||||
|
let new_ids_init = ref [] in
|
||||||
|
let env1 = Ident.create "env" in
|
||||||
|
let copy_env envs self =
|
||||||
|
if top then lambda_unit else
|
||||||
|
Lifused(env2, Lprim(Parraysetu Paddrarray,
|
||||||
|
[Lvar self; Lvar env2; lfield env1 0]))
|
||||||
|
and subst_env envs lam =
|
||||||
|
if top then lam else
|
||||||
|
Llet(Alias, env1, lfield envs 0,
|
||||||
|
subst_lambda (subst env1 lam 1 new_ids_init) lam)
|
||||||
|
in
|
||||||
|
|
||||||
|
(* Now we start compiling the class *)
|
||||||
let cla = Ident.create "class" in
|
let cla = Ident.create "class" in
|
||||||
let (inh_init, obj_init) = build_object_init_0 cla [] cl in
|
let (inh_init, obj_init) =
|
||||||
|
build_object_init_0 cla [] cl copy_env subst_env top ids in
|
||||||
if not (Translcore.check_recursive_lambda ids obj_init) then
|
if not (Translcore.check_recursive_lambda ids obj_init) then
|
||||||
raise(Error(cl.cl_loc, Illegal_class_expr));
|
raise(Error(cl.cl_loc, Illegal_class_expr));
|
||||||
let (inh_init, cl_init) =
|
let (inh_init', cl_init) =
|
||||||
build_class_init cla pub_meths true (List.rev inh_init) obj_init cl
|
build_class_init cla pub_meths true (List.rev inh_init)
|
||||||
|
obj_init msubst top cl
|
||||||
in
|
in
|
||||||
assert (inh_init = []);
|
assert (inh_init' = []);
|
||||||
let table = Ident.create "table" in
|
let table = Ident.create "table"
|
||||||
let class_init = Ident.create "class_init" in
|
and class_init = Ident.create "class_init"
|
||||||
let obj_init = Ident.create "obj_init" in
|
and env_init = Ident.create "env_init"
|
||||||
Llet(Strict, table,
|
and obj_init = Ident.create "obj_init" in
|
||||||
Lapply (oo_prim "create_table", [transl_meth_list pub_meths]),
|
let ltable table lam =
|
||||||
Llet(Strict, class_init,
|
Llet(Strict, table,
|
||||||
Lfunction(Curried, [cla], cl_init),
|
Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
|
||||||
Llet(Strict, obj_init, Lapply(Lvar class_init, [Lvar table]),
|
and ldirect obj_init =
|
||||||
Lsequence(Lapply (oo_prim "init_class", [Lvar table]),
|
Llet(Strict, obj_init, cl_init,
|
||||||
Lprim(Pmakeblock(0, Immutable),
|
Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
|
||||||
[Lvar obj_init;
|
Lapply(Lvar obj_init, [lambda_unit])))
|
||||||
Lvar class_init;
|
in
|
||||||
Lvar table])))))
|
(* Simplest case: an object defined at toplevel (ids=[]) *)
|
||||||
|
if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
|
||||||
|
|
||||||
let class_stub =
|
let lclass lam =
|
||||||
Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit])
|
Llet(Strict, class_init, Lfunction(Curried, [cla], cl_init), lam)
|
||||||
|
and lbody =
|
||||||
|
Lapply (oo_prim "make_class",
|
||||||
|
[transl_meth_list pub_meths; Lvar class_init])
|
||||||
|
in
|
||||||
|
(* Still easy: a class defined at toplevel *)
|
||||||
|
if top then llets (lclass lbody) else
|
||||||
|
|
||||||
|
(* Now for the hard stuff: prepare for table cacheing *)
|
||||||
|
let env_index = Ident.create "env_index"
|
||||||
|
and envs = Ident.create "envs" in
|
||||||
|
let lenvs =
|
||||||
|
if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
|
||||||
|
then lambda_unit
|
||||||
|
else Lvar envs in
|
||||||
|
let lenv =
|
||||||
|
if !new_ids_meths = [] && !new_ids_init = [] then lambda_unit else
|
||||||
|
Lprim(Pmakeblock(0, Immutable),
|
||||||
|
(if !new_ids_meths = [] then lambda_unit else
|
||||||
|
Lprim(Pmakeblock(0, Immutable),
|
||||||
|
List.map (fun id -> Lvar id) !new_ids_meths)) ::
|
||||||
|
List.map (fun id -> Lvar id) !new_ids_init)
|
||||||
|
and linh_envs =
|
||||||
|
List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
|
||||||
|
(List.rev inh_init)
|
||||||
|
in
|
||||||
|
let make_envs lam =
|
||||||
|
Llet(StrictOpt, envs,
|
||||||
|
Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs),
|
||||||
|
lam)
|
||||||
|
and def_ids cla lam =
|
||||||
|
Llet(StrictOpt, env2,
|
||||||
|
Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
|
||||||
|
lam)
|
||||||
|
in
|
||||||
|
let obj_init2 = Ident.create "obj_init"
|
||||||
|
and cached = Ident.create "cached" in
|
||||||
|
let inh_paths =
|
||||||
|
List.filter
|
||||||
|
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
|
||||||
|
let inh_keys =
|
||||||
|
List.map (fun (_,p) -> Lprim(Pfield 2, [transl_path p])) inh_paths in
|
||||||
|
let lclass lam =
|
||||||
|
Llet(Strict, class_init,
|
||||||
|
Lfunction(Curried, [cla], def_ids cla cl_init), lam)
|
||||||
|
and lcache lam =
|
||||||
|
if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
|
||||||
|
Llet(Strict, cached,
|
||||||
|
Lapply(oo_prim "lookup_tables",
|
||||||
|
[Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
|
||||||
|
lam)
|
||||||
|
and lset cached i lam =
|
||||||
|
Lprim(Psetfield(i, true), [Lvar cached; lam])
|
||||||
|
in
|
||||||
|
let ldirect () =
|
||||||
|
ltable cla
|
||||||
|
(Llet(Strict, env_init, def_ids cla cl_init,
|
||||||
|
Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
|
||||||
|
lset cached 0 (Lvar env_init))))
|
||||||
|
in
|
||||||
|
llets (
|
||||||
|
lcache (
|
||||||
|
Lsequence(
|
||||||
|
Lifthenelse(lfield cached 0, lambda_unit,
|
||||||
|
if ids = [] then ldirect () else
|
||||||
|
lclass (
|
||||||
|
Lapply (oo_prim "make_class_store",
|
||||||
|
[transl_meth_list pub_meths;
|
||||||
|
Lvar class_init; Lvar cached]))),
|
||||||
|
make_envs (
|
||||||
|
if ids = [] then Lapply(lfield cached 0, [lenvs]) else
|
||||||
|
Lprim(Pmakeblock(0, Immutable),
|
||||||
|
[Lapply(lfield cached 0, [lenvs]);
|
||||||
|
lfield cached 1;
|
||||||
|
lfield cached 0;
|
||||||
|
lenvs])))))
|
||||||
|
|
||||||
|
(* Dummy for recursive modules *)
|
||||||
|
|
||||||
let dummy_class undef_fn =
|
let dummy_class undef_fn =
|
||||||
Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; oo_prim "dummy_table"])
|
Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; undef_fn; lambda_unit])
|
||||||
|
|
||||||
|
(* Wrapper for class compilation *)
|
||||||
|
|
||||||
|
let transl_class ids cl_id arity pub_meths cl =
|
||||||
|
oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
|
||||||
|
|
||||||
|
let () =
|
||||||
|
transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
|
||||||
|
|
||||||
(* Error report *)
|
(* Error report *)
|
||||||
|
|
||||||
|
|
|
@ -15,7 +15,6 @@
|
||||||
open Typedtree
|
open Typedtree
|
||||||
open Lambda
|
open Lambda
|
||||||
|
|
||||||
val class_stub : lambda
|
|
||||||
val dummy_class : lambda -> lambda
|
val dummy_class : lambda -> lambda
|
||||||
val transl_class :
|
val transl_class :
|
||||||
Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
|
Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
|
||||||
|
|
|
@ -36,6 +36,10 @@ let transl_module =
|
||||||
ref((fun cc rootpath modl -> assert false) :
|
ref((fun cc rootpath modl -> assert false) :
|
||||||
module_coercion -> Path.t option -> module_expr -> lambda)
|
module_coercion -> Path.t option -> module_expr -> lambda)
|
||||||
|
|
||||||
|
let transl_object =
|
||||||
|
ref (fun id s cl -> assert false :
|
||||||
|
Ident.t -> string list -> class_expr -> lambda)
|
||||||
|
|
||||||
(* Translation of primitives *)
|
(* Translation of primitives *)
|
||||||
|
|
||||||
let comparisons_table = create_hashtable 11 [
|
let comparisons_table = create_hashtable 11 [
|
||||||
|
@ -500,9 +504,23 @@ let assert_failed loc =
|
||||||
(* Translation of expressions *)
|
(* Translation of expressions *)
|
||||||
|
|
||||||
let rec transl_exp e =
|
let rec transl_exp e =
|
||||||
|
let eval_once =
|
||||||
|
(* Whether classes for immediate objects must be cached *)
|
||||||
|
match e.exp_desc with
|
||||||
|
Texp_function _ | Texp_for _ | Texp_while _ -> false
|
||||||
|
| _ -> true
|
||||||
|
in
|
||||||
|
if eval_once then transl_exp0 e else
|
||||||
|
Translobj.oo_wrap e.exp_env true transl_exp0 e
|
||||||
|
|
||||||
|
and transl_exp0 e =
|
||||||
match e.exp_desc with
|
match e.exp_desc with
|
||||||
Texp_ident(path, {val_kind = Val_prim p}) ->
|
Texp_ident(path, {val_kind = Val_prim p}) ->
|
||||||
transl_primitive p
|
if p.prim_name = "%send" then
|
||||||
|
let obj = Ident.create "obj" and meth = Ident.create "meth" in
|
||||||
|
Lfunction(Curried, [obj; meth], Lsend(Lvar meth, Lvar obj, []))
|
||||||
|
else
|
||||||
|
transl_primitive p
|
||||||
| Texp_ident(path, {val_kind = Val_anc _}) ->
|
| Texp_ident(path, {val_kind = Val_anc _}) ->
|
||||||
raise(Error(e.exp_loc, Free_super_var))
|
raise(Error(e.exp_loc, Free_super_var))
|
||||||
| Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
|
| Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
|
||||||
|
@ -524,7 +542,10 @@ let rec transl_exp e =
|
||||||
when List.length args = p.prim_arity
|
when List.length args = p.prim_arity
|
||||||
&& List.for_all (fun (arg,_) -> arg <> None) args ->
|
&& List.for_all (fun (arg,_) -> arg <> None) args ->
|
||||||
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
|
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
|
||||||
let prim = transl_prim p args in
|
if p.prim_name = "%send" then
|
||||||
|
let obj = transl_exp (List.hd args) in
|
||||||
|
event_after e (Lsend (transl_exp (List.nth args 1), obj, []))
|
||||||
|
else let prim = transl_prim p args in
|
||||||
begin match (prim, args) with
|
begin match (prim, args) with
|
||||||
(Praise, [arg1]) ->
|
(Praise, [arg1]) ->
|
||||||
Lprim(Praise, [event_after arg1 (transl_exp arg1)])
|
Lprim(Praise, [event_after arg1 (transl_exp arg1)])
|
||||||
|
@ -665,6 +686,13 @@ let rec transl_exp e =
|
||||||
| Texp_lazy e ->
|
| Texp_lazy e ->
|
||||||
let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
|
let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
|
||||||
Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
|
Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
|
||||||
|
| Texp_object (cs, cty, meths) ->
|
||||||
|
let cl = Ident.create "class" in
|
||||||
|
!transl_object cl meths
|
||||||
|
{ cl_desc = Tclass_structure cs;
|
||||||
|
cl_loc = e.exp_loc;
|
||||||
|
cl_type = Tcty_signature cty;
|
||||||
|
cl_env = e.exp_env }
|
||||||
|
|
||||||
and transl_list expr_list =
|
and transl_list expr_list =
|
||||||
List.map transl_exp expr_list
|
List.map transl_exp expr_list
|
||||||
|
@ -735,33 +763,6 @@ and transl_function loc untuplify_fn repr partial pat_expr_list =
|
||||||
transl_function exp.exp_loc false repr partial' pl in
|
transl_function exp.exp_loc false repr partial' pl in
|
||||||
((Curried, param :: params),
|
((Curried, param :: params),
|
||||||
Matching.for_function loc None (Lvar param) [pat, body] partial)
|
Matching.for_function loc None (Lvar param) [pat, body] partial)
|
||||||
(*
|
|
||||||
| [({pat_desc = Tpat_var id} as pat),
|
|
||||||
({exp_desc = Texp_let(Nonrecursive, cases,
|
|
||||||
({exp_desc = Texp_function _} as e2))} as e1)]
|
|
||||||
when Ident.name id = "*opt*" ->
|
|
||||||
transl_function loc untuplify_fn repr (cases::bindings) partial [pat, e2]
|
|
||||||
| [pat, exp] when bindings <> [] ->
|
|
||||||
let exp =
|
|
||||||
List.fold_left
|
|
||||||
(fun exp cases ->
|
|
||||||
{exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
|
|
||||||
exp bindings
|
|
||||||
in
|
|
||||||
transl_function loc untuplify_fn repr [] partial [pat, exp]
|
|
||||||
| (pat, exp)::_ when bindings <> [] ->
|
|
||||||
let param = name_pattern "param" pat_expr_list in
|
|
||||||
let exp =
|
|
||||||
{ exp with exp_loc = loc; exp_desc =
|
|
||||||
Texp_match
|
|
||||||
({exp with exp_type = pat.pat_type; exp_desc =
|
|
||||||
Texp_ident (Path.Pident param,
|
|
||||||
{val_type = pat.pat_type; val_kind = Val_reg})},
|
|
||||||
pat_expr_list, partial) }
|
|
||||||
in
|
|
||||||
transl_function loc untuplify_fn repr bindings Total
|
|
||||||
[{pat with pat_desc = Tpat_var param}, exp]
|
|
||||||
*)
|
|
||||||
| ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
|
| ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
|
||||||
begin try
|
begin try
|
||||||
let size = List.length pl in
|
let size = List.length pl in
|
||||||
|
@ -877,6 +878,19 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
|
||||||
end
|
end
|
||||||
end
|
end
|
||||||
|
|
||||||
|
(* Wrapper for class compilation *)
|
||||||
|
|
||||||
|
(*
|
||||||
|
let transl_exp = transl_exp_wrap
|
||||||
|
|
||||||
|
let transl_let rec_flag pat_expr_list body =
|
||||||
|
match pat_expr_list with
|
||||||
|
[] -> body
|
||||||
|
| (_, expr) :: _ ->
|
||||||
|
Translobj.oo_wrap expr.exp_env false
|
||||||
|
(transl_let rec_flag pat_expr_list) body
|
||||||
|
*)
|
||||||
|
|
||||||
(* Compile an exception definition *)
|
(* Compile an exception definition *)
|
||||||
|
|
||||||
let transl_exception id path decl =
|
let transl_exception id path decl =
|
||||||
|
|
|
@ -46,3 +46,5 @@ val report_error: formatter -> error -> unit
|
||||||
(* Forward declaration -- to be filled in by Translmod.transl_module *)
|
(* Forward declaration -- to be filled in by Translmod.transl_module *)
|
||||||
val transl_module :
|
val transl_module :
|
||||||
(module_coercion -> Path.t option -> module_expr -> lambda) ref
|
(module_coercion -> Path.t option -> module_expr -> lambda) ref
|
||||||
|
val transl_object :
|
||||||
|
(Ident.t -> string list -> class_expr -> lambda) ref
|
||||||
|
|
|
@ -248,19 +248,22 @@ let rec transl_module cc rootpath mexp =
|
||||||
transl_structure [] cc rootpath str
|
transl_structure [] cc rootpath str
|
||||||
| Tmod_functor(param, mty, body) ->
|
| Tmod_functor(param, mty, body) ->
|
||||||
let bodypath = functor_path rootpath param in
|
let bodypath = functor_path rootpath param in
|
||||||
begin match cc with
|
oo_wrap mexp.mod_env true
|
||||||
Tcoerce_none ->
|
(function
|
||||||
Lfunction(Curried, [param], transl_module Tcoerce_none bodypath body)
|
| Tcoerce_none ->
|
||||||
| Tcoerce_functor(ccarg, ccres) ->
|
Lfunction(Curried, [param],
|
||||||
let param' = Ident.create "funarg" in
|
transl_module Tcoerce_none bodypath body)
|
||||||
Lfunction(Curried, [param'],
|
| Tcoerce_functor(ccarg, ccres) ->
|
||||||
Llet(Alias, param, apply_coercion ccarg (Lvar param'),
|
let param' = Ident.create "funarg" in
|
||||||
transl_module ccres bodypath body))
|
Lfunction(Curried, [param'],
|
||||||
| _ ->
|
Llet(Alias, param, apply_coercion ccarg (Lvar param'),
|
||||||
fatal_error "Translmod.transl_module"
|
transl_module ccres bodypath body))
|
||||||
end
|
| _ ->
|
||||||
|
fatal_error "Translmod.transl_module")
|
||||||
|
cc
|
||||||
| Tmod_apply(funct, arg, ccarg) ->
|
| Tmod_apply(funct, arg, ccarg) ->
|
||||||
apply_coercion cc
|
oo_wrap mexp.mod_env true
|
||||||
|
(apply_coercion cc)
|
||||||
(Lapply(transl_module Tcoerce_none None funct,
|
(Lapply(transl_module Tcoerce_none None funct,
|
||||||
[transl_module ccarg None arg]))
|
[transl_module ccarg None arg]))
|
||||||
| Tmod_constraint(arg, mty, ccarg) ->
|
| Tmod_constraint(arg, mty, ccarg) ->
|
||||||
|
|
|
@ -26,6 +26,22 @@ let oo_prim name =
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
fatal_error ("Primitive " ^ name ^ " not found.")
|
fatal_error ("Primitive " ^ name ^ " not found.")
|
||||||
|
|
||||||
|
(* Share blocks *)
|
||||||
|
|
||||||
|
let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17
|
||||||
|
|
||||||
|
let share c =
|
||||||
|
match c with
|
||||||
|
Const_block (n, l) when l <> [] ->
|
||||||
|
begin try
|
||||||
|
Lvar (Hashtbl.find consts c)
|
||||||
|
with Not_found ->
|
||||||
|
let id = Ident.create "shared" in
|
||||||
|
Hashtbl.add consts c id;
|
||||||
|
Lvar id
|
||||||
|
end
|
||||||
|
| _ -> Lconst c
|
||||||
|
|
||||||
(* Collect labels *)
|
(* Collect labels *)
|
||||||
|
|
||||||
let used_methods = ref ([] : (string * Ident.t) list);;
|
let used_methods = ref ([] : (string * Ident.t) list);;
|
||||||
|
@ -39,6 +55,7 @@ let meth lab =
|
||||||
id
|
id
|
||||||
|
|
||||||
let reset_labels () =
|
let reset_labels () =
|
||||||
|
Hashtbl.clear consts;
|
||||||
used_methods := []
|
used_methods := []
|
||||||
|
|
||||||
(* Insert labels *)
|
(* Insert labels *)
|
||||||
|
@ -46,17 +63,61 @@ let reset_labels () =
|
||||||
let string s = Lconst (Const_base (Const_string s))
|
let string s = Lconst (Const_base (Const_string s))
|
||||||
|
|
||||||
let transl_label_init expr =
|
let transl_label_init expr =
|
||||||
if !used_methods = [] then
|
let expr =
|
||||||
expr
|
Hashtbl.fold
|
||||||
else
|
(fun c id expr -> Llet(Alias, id, Lconst c, expr))
|
||||||
|
consts expr
|
||||||
|
in
|
||||||
|
let expr =
|
||||||
|
if !used_methods = [] then expr else
|
||||||
let init = Ident.create "new_method" in
|
let init = Ident.create "new_method" in
|
||||||
let expr' =
|
Llet(StrictOpt, init, oo_prim "new_method",
|
||||||
Llet(StrictOpt, init, oo_prim "new_method",
|
List.fold_right
|
||||||
List.fold_right
|
(fun (lab, id) expr ->
|
||||||
(fun (lab, id) expr ->
|
Llet(StrictOpt, id, Lapply(Lvar init, [string lab]), expr))
|
||||||
Llet(StrictOpt, id, Lapply(Lvar init, [string lab]), expr))
|
!used_methods
|
||||||
!used_methods
|
expr)
|
||||||
expr)
|
in
|
||||||
|
reset_labels ();
|
||||||
|
expr
|
||||||
|
|
||||||
|
|
||||||
|
(* Share classes *)
|
||||||
|
|
||||||
|
let wrapping = ref false
|
||||||
|
let required = ref true
|
||||||
|
let top_env = ref Env.empty
|
||||||
|
let classes = ref []
|
||||||
|
|
||||||
|
let oo_add_class id =
|
||||||
|
classes := id :: !classes;
|
||||||
|
(!top_env, !required)
|
||||||
|
|
||||||
|
let oo_wrap env req f x =
|
||||||
|
if !wrapping then
|
||||||
|
if !required then f x else
|
||||||
|
try required := true; let lam = f x in required := false; lam
|
||||||
|
with exn -> required := false; raise exn
|
||||||
|
else try
|
||||||
|
wrapping := true;
|
||||||
|
required := req;
|
||||||
|
top_env := env;
|
||||||
|
classes := [];
|
||||||
|
let lambda = f x in
|
||||||
|
let lambda =
|
||||||
|
List.fold_left
|
||||||
|
(fun lambda id ->
|
||||||
|
Llet(StrictOpt, id,
|
||||||
|
Lprim(Pmakeblock(0, Mutable),
|
||||||
|
[lambda_unit; lambda_unit; lambda_unit]),
|
||||||
|
lambda))
|
||||||
|
lambda !classes
|
||||||
in
|
in
|
||||||
reset_labels ();
|
wrapping := false;
|
||||||
expr'
|
top_env := Env.empty;
|
||||||
|
lambda
|
||||||
|
with exn ->
|
||||||
|
wrapping := false;
|
||||||
|
top_env := Env.empty;
|
||||||
|
raise exn
|
||||||
|
|
||||||
|
|
|
@ -12,9 +12,15 @@
|
||||||
|
|
||||||
(* $Id$ *)
|
(* $Id$ *)
|
||||||
|
|
||||||
val oo_prim: string -> Lambda.lambda
|
open Lambda
|
||||||
|
|
||||||
|
val oo_prim: string -> lambda
|
||||||
|
|
||||||
|
val share: structured_constant -> lambda
|
||||||
val meth: string -> Ident.t
|
val meth: string -> Ident.t
|
||||||
|
|
||||||
val reset_labels: unit -> unit
|
val reset_labels: unit -> unit
|
||||||
val transl_label_init: Lambda.lambda -> Lambda.lambda
|
val transl_label_init: lambda -> lambda
|
||||||
|
|
||||||
|
val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
|
||||||
|
val oo_add_class: Ident.t -> Env.t * bool
|
||||||
|
|
|
@ -674,6 +674,23 @@ let rec search_pos_structure ~pos str =
|
||||||
| Tstr_include (m, _) -> search_pos_module_expr m ~pos
|
| Tstr_include (m, _) -> search_pos_module_expr m ~pos
|
||||||
end
|
end
|
||||||
|
|
||||||
|
and search_pos_class_structure ~pos cls =
|
||||||
|
List.iter cls.cl_field ~f:
|
||||||
|
begin function
|
||||||
|
Cf_inher (cl, _, _) ->
|
||||||
|
search_pos_class_expr cl ~pos
|
||||||
|
| Cf_val (_, _, exp) -> search_pos_expr exp ~pos
|
||||||
|
| Cf_meth (_, exp) -> search_pos_expr exp ~pos
|
||||||
|
| Cf_let (_, pel, iel) ->
|
||||||
|
List.iter pel ~f:
|
||||||
|
begin fun (pat, exp) ->
|
||||||
|
search_pos_pat pat ~pos ~env:exp.exp_env;
|
||||||
|
search_pos_expr exp ~pos
|
||||||
|
end;
|
||||||
|
List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
|
||||||
|
| Cf_init exp -> search_pos_expr exp ~pos
|
||||||
|
end
|
||||||
|
|
||||||
and search_pos_class_expr ~pos cl =
|
and search_pos_class_expr ~pos cl =
|
||||||
if in_loc cl.cl_loc ~pos then begin
|
if in_loc cl.cl_loc ~pos then begin
|
||||||
begin match cl.cl_desc with
|
begin match cl.cl_desc with
|
||||||
|
@ -681,21 +698,7 @@ and search_pos_class_expr ~pos cl =
|
||||||
add_found_str (`Class (path, cl.cl_type))
|
add_found_str (`Class (path, cl.cl_type))
|
||||||
~env:!start_env ~loc:cl.cl_loc
|
~env:!start_env ~loc:cl.cl_loc
|
||||||
| Tclass_structure cls ->
|
| Tclass_structure cls ->
|
||||||
List.iter cls.cl_field ~f:
|
search_pos_class_structure ~pos cls
|
||||||
begin function
|
|
||||||
Cf_inher (cl, _, _) ->
|
|
||||||
search_pos_class_expr cl ~pos
|
|
||||||
| Cf_val (_, _, exp) -> search_pos_expr exp ~pos
|
|
||||||
| Cf_meth (_, exp) -> search_pos_expr exp ~pos
|
|
||||||
| Cf_let (_, pel, iel) ->
|
|
||||||
List.iter pel ~f:
|
|
||||||
begin fun (pat, exp) ->
|
|
||||||
search_pos_pat pat ~pos ~env:exp.exp_env;
|
|
||||||
search_pos_expr exp ~pos
|
|
||||||
end;
|
|
||||||
List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
|
|
||||||
| Cf_init exp -> search_pos_expr exp ~pos
|
|
||||||
end
|
|
||||||
| Tclass_fun (pat, iel, cl, _) ->
|
| Tclass_fun (pat, iel, cl, _) ->
|
||||||
search_pos_pat pat ~pos ~env:pat.pat_env;
|
search_pos_pat pat ~pos ~env:pat.pat_env;
|
||||||
List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
|
List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
|
||||||
|
@ -802,6 +805,9 @@ and search_pos_expr ~pos exp =
|
||||||
search_pos_expr exp ~pos
|
search_pos_expr exp ~pos
|
||||||
| Texp_lazy exp ->
|
| Texp_lazy exp ->
|
||||||
search_pos_expr exp ~pos
|
search_pos_expr exp ~pos
|
||||||
|
| Texp_object (cls, _, _) ->
|
||||||
|
search_pos_class_structure ~pos cls
|
||||||
|
|
||||||
end;
|
end;
|
||||||
add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
|
add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
|
||||||
end
|
end
|
||||||
|
|
|
@ -31,8 +31,8 @@ BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
|
||||||
set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \
|
set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \
|
||||||
printf.cmo format.cmo scanf.cmo \
|
printf.cmo format.cmo scanf.cmo \
|
||||||
arg.cmo printexc.cmo gc.cmo \
|
arg.cmo printexc.cmo gc.cmo \
|
||||||
digest.cmo random.cmo camlinternalOO.cmo oo.cmo \
|
digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \
|
||||||
genlex.cmo callback.cmo weak.cmo \
|
genlex.cmo weak.cmo \
|
||||||
lazy.cmo filename.cmo complex.cmo
|
lazy.cmo filename.cmo complex.cmo
|
||||||
LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
|
LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
|
||||||
|
|
||||||
|
@ -119,6 +119,9 @@ pervasives.p.cmx: pervasives.ml
|
||||||
camlinternalOO.cmi: camlinternalOO.mli
|
camlinternalOO.cmi: camlinternalOO.mli
|
||||||
$(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
|
$(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
|
||||||
|
|
||||||
|
camlinternalOO.cmx: camlinternalOO.ml
|
||||||
|
$(CAMLOPT) $(OPTCOMPFLAGS) -inline 0 camlinternalOO.ml
|
||||||
|
|
||||||
# labelled modules require the -nolabels flag
|
# labelled modules require the -nolabels flag
|
||||||
labelled.cmo:
|
labelled.cmo:
|
||||||
$(MAKE) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) \
|
$(MAKE) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) \
|
||||||
|
|
|
@ -327,7 +327,13 @@ let get_method table label =
|
||||||
let (buck, elem) = decode label in
|
let (buck, elem) = decode label in
|
||||||
table.buckets.(buck).(elem)
|
table.buckets.(buck).(elem)
|
||||||
|
|
||||||
|
let to_list arr =
|
||||||
|
if arr == magic 0 then [] else Array.to_list arr
|
||||||
|
|
||||||
let narrow table vars virt_meths concr_meths =
|
let narrow table vars virt_meths concr_meths =
|
||||||
|
let vars = to_list vars
|
||||||
|
and virt_meths = to_list virt_meths
|
||||||
|
and concr_meths = to_list concr_meths in
|
||||||
let virt_meth_labs = List.map (get_method_label table) virt_meths in
|
let virt_meth_labs = List.map (get_method_label table) virt_meths in
|
||||||
let concr_meth_labs = List.map (get_method_label table) concr_meths in
|
let concr_meth_labs = List.map (get_method_label table) concr_meths in
|
||||||
table.previous_states <-
|
table.previous_states <-
|
||||||
|
@ -387,6 +393,13 @@ let new_variable table name =
|
||||||
table.vars <- Vars.add name index table.vars;
|
table.vars <- Vars.add name index table.vars;
|
||||||
index
|
index
|
||||||
|
|
||||||
|
let new_variables table names =
|
||||||
|
let index = new_variable table names.(0) in
|
||||||
|
for i = 1 to Array.length names - 1 do
|
||||||
|
ignore (new_variable table names.(i))
|
||||||
|
done;
|
||||||
|
index
|
||||||
|
|
||||||
let get_variable table name =
|
let get_variable table name =
|
||||||
Vars.find name table.vars
|
Vars.find name table.vars
|
||||||
|
|
||||||
|
@ -395,12 +408,13 @@ let add_initializer table f =
|
||||||
|
|
||||||
let create_table public_methods =
|
let create_table public_methods =
|
||||||
let table = new_table () in
|
let table = new_table () in
|
||||||
List.iter
|
if public_methods != magic 0 then
|
||||||
(function met ->
|
Array.iter
|
||||||
let lab = new_method met in
|
(function met ->
|
||||||
table.methods_by_name <- Meths.add met lab table.methods_by_name;
|
let lab = new_method met in
|
||||||
table.methods_by_label <- Labs.add lab true table.methods_by_label)
|
table.methods_by_name <- Meths.add met lab table.methods_by_name;
|
||||||
public_methods;
|
table.methods_by_label <- Labs.add lab true table.methods_by_label)
|
||||||
|
public_methods;
|
||||||
table
|
table
|
||||||
|
|
||||||
let init_class table =
|
let init_class table =
|
||||||
|
@ -409,6 +423,28 @@ let init_class table =
|
||||||
compact_buckets table.buckets;
|
compact_buckets table.buckets;
|
||||||
table.initializers <- List.rev table.initializers
|
table.initializers <- List.rev table.initializers
|
||||||
|
|
||||||
|
let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
|
||||||
|
narrow cla vals virt_meths concr_meths;
|
||||||
|
let init =
|
||||||
|
if top then super cla env else Obj.repr (super cla) in
|
||||||
|
widen cla;
|
||||||
|
init
|
||||||
|
|
||||||
|
let make_class pub_meths class_init =
|
||||||
|
let table = create_table pub_meths in
|
||||||
|
let env_init = class_init table in
|
||||||
|
init_class table;
|
||||||
|
(env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
|
||||||
|
|
||||||
|
type init_table = { mutable env_init: t; mutable class_init: table -> t }
|
||||||
|
|
||||||
|
let make_class_store pub_meths class_init init_table =
|
||||||
|
let table = create_table pub_meths in
|
||||||
|
let env_init = class_init table in
|
||||||
|
init_class table;
|
||||||
|
init_table.class_init <- class_init;
|
||||||
|
init_table.env_init <- env_init
|
||||||
|
|
||||||
(**** Objects ****)
|
(**** Objects ****)
|
||||||
|
|
||||||
let create_object table =
|
let create_object table =
|
||||||
|
@ -453,9 +489,148 @@ let create_object_and_run_initializers obj_0 table =
|
||||||
obj
|
obj
|
||||||
end
|
end
|
||||||
|
|
||||||
|
(* Equivalent primitive below
|
||||||
let send obj lab =
|
let send obj lab =
|
||||||
let (buck, elem) = decode lab in
|
let (buck, elem) = decode lab in
|
||||||
(magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
|
(magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
|
||||||
|
*)
|
||||||
|
external send : obj -> label -> 'a = "%send"
|
||||||
|
|
||||||
|
(**** table collection access ****)
|
||||||
|
|
||||||
|
type tables = Empty | Cons of table * tables * tables
|
||||||
|
type mut_tables =
|
||||||
|
{key: table; mutable data: tables; mutable next: tables}
|
||||||
|
external mut : tables -> mut_tables = "%identity"
|
||||||
|
|
||||||
|
let build_path n keys tables =
|
||||||
|
let res = Cons (Obj.magic 0, Empty, Empty) in
|
||||||
|
let r = ref res in
|
||||||
|
for i = 0 to n do
|
||||||
|
r := Cons (keys.(i), !r, Empty)
|
||||||
|
done;
|
||||||
|
tables.data <- !r;
|
||||||
|
res
|
||||||
|
|
||||||
|
let rec lookup_keys i keys tables =
|
||||||
|
if i < 0 then tables else
|
||||||
|
let key = keys.(i) in
|
||||||
|
let rec lookup_key tables =
|
||||||
|
if tables.key == key then lookup_keys (i-1) keys tables.data else
|
||||||
|
if tables.next <> Empty then lookup_key (mut tables.next) else
|
||||||
|
let next = Cons (key, Empty, Empty) in
|
||||||
|
tables.next <- next;
|
||||||
|
build_path (i-1) keys (mut next)
|
||||||
|
in
|
||||||
|
lookup_key (mut tables)
|
||||||
|
|
||||||
|
let lookup_tables root keys =
|
||||||
|
let root = mut root in
|
||||||
|
if root.data <> Empty then
|
||||||
|
lookup_keys (Array.length keys - 1) keys root.data
|
||||||
|
else
|
||||||
|
build_path (Array.length keys - 1) keys root
|
||||||
|
|
||||||
|
(**** builtin methods ****)
|
||||||
|
|
||||||
|
type closure = item
|
||||||
|
external ret : (obj -> 'a) -> closure = "%identity"
|
||||||
|
|
||||||
|
let get_const x = ret (fun obj -> x)
|
||||||
|
let get_var n = ret (fun obj -> Array.unsafe_get obj n)
|
||||||
|
let get_env e n = ret (fun obj -> Obj.field (Array.unsafe_get obj e) n)
|
||||||
|
let get_meth n = ret (fun obj -> send obj n)
|
||||||
|
let set_var n = ret (fun obj x -> Array.unsafe_set obj n x)
|
||||||
|
let app_const f x = ret (fun obj -> f x)
|
||||||
|
let app_var f n = ret (fun obj -> f (Array.unsafe_get obj n))
|
||||||
|
let app_env f e n = ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n))
|
||||||
|
let app_meth f n = ret (fun obj -> f (send obj n))
|
||||||
|
let app_const_const f x y = ret (fun obj -> f x y)
|
||||||
|
let app_const_var f x n = ret (fun obj -> f x (Array.unsafe_get obj n))
|
||||||
|
let app_const_meth f x n = ret (fun obj -> f x (send obj n))
|
||||||
|
let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
|
||||||
|
let app_meth_const f n x = ret (fun obj -> f (send obj n) x)
|
||||||
|
let app_const_env f x e n =
|
||||||
|
ret (fun obj -> f x (Obj.field (Array.unsafe_get obj e) n))
|
||||||
|
let app_env_const f e n x =
|
||||||
|
ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n) x)
|
||||||
|
let meth_app_const n x = ret (fun obj -> (send obj n) x)
|
||||||
|
let meth_app_var n m =
|
||||||
|
ret (fun obj -> (send obj n) (Array.unsafe_get obj m))
|
||||||
|
let meth_app_env n e m =
|
||||||
|
ret (fun obj -> (send obj n) (Obj.field (Array.unsafe_get obj e) m))
|
||||||
|
let meth_app_meth n m =
|
||||||
|
ret (fun obj -> (send obj n) (send obj m))
|
||||||
|
|
||||||
|
type impl =
|
||||||
|
GetConst
|
||||||
|
| GetVar
|
||||||
|
| GetEnv
|
||||||
|
| GetMeth
|
||||||
|
| SetVar
|
||||||
|
| AppConst
|
||||||
|
| AppVar
|
||||||
|
| AppEnv
|
||||||
|
| AppMeth
|
||||||
|
| AppConstConst
|
||||||
|
| AppConstVar
|
||||||
|
| AppConstEnv
|
||||||
|
| AppConstMeth
|
||||||
|
| AppVarConst
|
||||||
|
| AppEnvConst
|
||||||
|
| AppMethConst
|
||||||
|
| MethAppConst
|
||||||
|
| MethAppVar
|
||||||
|
| MethAppEnv
|
||||||
|
| MethAppMeth
|
||||||
|
| Closure of Obj.t
|
||||||
|
|
||||||
|
let method_impl i arr =
|
||||||
|
let next () = incr i; magic arr.(!i) in
|
||||||
|
match next() with
|
||||||
|
GetConst -> let x : t = next() in ret (fun obj -> x)
|
||||||
|
| GetVar -> let n = next() in get_var n
|
||||||
|
| GetEnv -> let e = next() and n = next() in get_env e n
|
||||||
|
| GetMeth -> let n = next() in get_meth n
|
||||||
|
| SetVar -> let n = next() in set_var n
|
||||||
|
| AppConst -> let f = next() and x = next() in ret (fun obj -> f x)
|
||||||
|
| AppVar -> let f = next() and n = next () in app_var f n
|
||||||
|
| AppEnv ->
|
||||||
|
let f = next() and e = next() and n = next() in app_env f e n
|
||||||
|
| AppMeth -> let f = next() and n = next () in app_meth f n
|
||||||
|
| AppConstConst ->
|
||||||
|
let f = next() and x = next() and y = next() in ret (fun obj -> f x y)
|
||||||
|
| AppConstVar ->
|
||||||
|
let f = next() and x = next() and n = next() in app_const_var f x n
|
||||||
|
| AppConstEnv ->
|
||||||
|
let f = next() and x = next() and e = next () and n = next() in
|
||||||
|
app_const_env f x e n
|
||||||
|
| AppConstMeth ->
|
||||||
|
let f = next() and x = next() and n = next() in app_const_meth f x n
|
||||||
|
| AppVarConst ->
|
||||||
|
let f = next() and n = next() and x = next() in app_var_const f n x
|
||||||
|
| AppEnvConst ->
|
||||||
|
let f = next() and e = next () and n = next() and x = next() in
|
||||||
|
app_env_const f e n x
|
||||||
|
| AppMethConst ->
|
||||||
|
let f = next() and n = next() and x = next() in app_meth_const f n x
|
||||||
|
| MethAppConst ->
|
||||||
|
let n = next() and x = next() in meth_app_const n x
|
||||||
|
| MethAppVar ->
|
||||||
|
let n = next() and m = next() in meth_app_var n m
|
||||||
|
| MethAppEnv ->
|
||||||
|
let n = next() and e = next() and m = next() in meth_app_env n e m
|
||||||
|
| MethAppMeth ->
|
||||||
|
let n = next() and m = next() in meth_app_meth n m
|
||||||
|
| Closure _ as clo -> magic clo
|
||||||
|
|
||||||
|
let set_methods table methods =
|
||||||
|
let len = Array.length methods and i = ref 0 in
|
||||||
|
while !i < len do
|
||||||
|
let label = methods.(!i) and clo = method_impl i methods in
|
||||||
|
set_method table label clo;
|
||||||
|
incr i
|
||||||
|
done
|
||||||
|
|
||||||
(**** Statistics ****)
|
(**** Statistics ****)
|
||||||
|
|
||||||
|
|
|
@ -30,16 +30,27 @@ type meth
|
||||||
type t
|
type t
|
||||||
type obj
|
type obj
|
||||||
val new_variable : table -> string -> int
|
val new_variable : table -> string -> int
|
||||||
|
val new_variables : table -> string array -> int
|
||||||
val get_variable : table -> string -> int
|
val get_variable : table -> string -> int
|
||||||
val get_method_label : table -> string -> label
|
val get_method_label : table -> string -> label
|
||||||
val get_method : table -> label -> meth
|
val get_method : table -> label -> meth
|
||||||
val set_method : table -> label -> meth -> unit
|
val set_method : table -> label -> meth -> unit
|
||||||
val narrow : table -> string list -> string list -> string list -> unit
|
val set_methods : table -> label array -> unit
|
||||||
|
val narrow : table -> string array -> string array -> string array -> unit
|
||||||
val widen : table -> unit
|
val widen : table -> unit
|
||||||
val add_initializer : table -> (obj -> unit) -> unit
|
val add_initializer : table -> (obj -> unit) -> unit
|
||||||
val dummy_table : table
|
val dummy_table : table
|
||||||
val create_table : string list -> table
|
val create_table : string array -> table
|
||||||
val init_class : table -> unit
|
val init_class : table -> unit
|
||||||
|
val inherits :
|
||||||
|
table -> string array -> string array -> string array ->
|
||||||
|
(t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t
|
||||||
|
val make_class :
|
||||||
|
string array -> (table -> Obj.t -> t) ->
|
||||||
|
(t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
|
||||||
|
type init_table
|
||||||
|
val make_class_store :
|
||||||
|
string array -> (table -> t) -> init_table -> unit
|
||||||
|
|
||||||
(** {6 Objects} *)
|
(** {6 Objects} *)
|
||||||
|
|
||||||
|
@ -49,7 +60,60 @@ val create_object_opt : obj -> table -> obj
|
||||||
val run_initializers : obj -> table -> unit
|
val run_initializers : obj -> table -> unit
|
||||||
val run_initializers_opt : obj -> obj -> table -> obj
|
val run_initializers_opt : obj -> obj -> table -> obj
|
||||||
val create_object_and_run_initializers : obj -> table -> obj
|
val create_object_and_run_initializers : obj -> table -> obj
|
||||||
val send : obj -> label -> t
|
external send : obj -> label -> t = "%send"
|
||||||
|
|
||||||
|
(** {6 Table cache} *)
|
||||||
|
|
||||||
|
type tables
|
||||||
|
val lookup_tables : tables -> table array -> tables
|
||||||
|
|
||||||
|
(** {6 Builtins to reduce code size} *)
|
||||||
|
|
||||||
|
open Obj
|
||||||
|
type closure
|
||||||
|
val get_const : t -> closure
|
||||||
|
val get_var : int -> closure
|
||||||
|
val get_env : int -> int -> closure
|
||||||
|
val get_meth : label -> closure
|
||||||
|
val set_var : int -> closure
|
||||||
|
val app_const : (t -> t) -> t -> closure
|
||||||
|
val app_var : (t -> t) -> int -> closure
|
||||||
|
val app_env : (t -> t) -> int -> int -> closure
|
||||||
|
val app_meth : (t -> t) -> label -> closure
|
||||||
|
val app_const_const : (t -> t -> t) -> t -> t -> closure
|
||||||
|
val app_const_var : (t -> t -> t) -> t -> int -> closure
|
||||||
|
val app_const_env : (t -> t -> t) -> t -> int -> int -> closure
|
||||||
|
val app_const_meth : (t -> t -> t) -> t -> label -> closure
|
||||||
|
val app_var_const : (t -> t -> t) -> int -> t -> closure
|
||||||
|
val app_env_const : (t -> t -> t) -> int -> int -> t -> closure
|
||||||
|
val app_meth_const : (t -> t -> t) -> label -> t -> closure
|
||||||
|
val meth_app_const : label -> t -> closure
|
||||||
|
val meth_app_var : label -> int -> closure
|
||||||
|
val meth_app_env : label -> int -> int -> closure
|
||||||
|
val meth_app_meth : label -> label -> closure
|
||||||
|
|
||||||
|
type impl =
|
||||||
|
GetConst
|
||||||
|
| GetVar
|
||||||
|
| GetEnv
|
||||||
|
| GetMeth
|
||||||
|
| SetVar
|
||||||
|
| AppConst
|
||||||
|
| AppVar
|
||||||
|
| AppEnv
|
||||||
|
| AppMeth
|
||||||
|
| AppConstConst
|
||||||
|
| AppConstVar
|
||||||
|
| AppConstEnv
|
||||||
|
| AppConstMeth
|
||||||
|
| AppVarConst
|
||||||
|
| AppEnvConst
|
||||||
|
| AppMethConst
|
||||||
|
| MethAppConst
|
||||||
|
| MethAppVar
|
||||||
|
| MethAppEnv
|
||||||
|
| MethAppMeth
|
||||||
|
| Closure of t
|
||||||
|
|
||||||
(** {6 Parameters} *)
|
(** {6 Parameters} *)
|
||||||
|
|
||||||
|
|
|
@ -78,4 +78,4 @@ let catch_break on =
|
||||||
|
|
||||||
(* OCaml version string, must be in the format described in sys.mli. *)
|
(* OCaml version string, must be in the format described in sys.mli. *)
|
||||||
|
|
||||||
let ocaml_version = "3.07+5 (2003-11-19)";;
|
let ocaml_version = "3.07+6 (2003-11-25)";;
|
||||||
|
|
|
@ -276,7 +276,7 @@ let rec add_labels_expr ~text ~values ~classes expr =
|
||||||
| Pexp_override lst ->
|
| Pexp_override lst ->
|
||||||
List.iter lst ~f:(fun (_,e) -> add_labels_rec e)
|
List.iter lst ~f:(fun (_,e) -> add_labels_rec e)
|
||||||
| Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _
|
| Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _
|
||||||
| Pexp_new _ | Pexp_assertfalse ->
|
| Pexp_new _ | Pexp_assertfalse | Pexp_object _ ->
|
||||||
()
|
()
|
||||||
|
|
||||||
let rec add_labels_class ~text ~classes ~values ~methods cl =
|
let rec add_labels_class ~text ~classes ~values ~methods cl =
|
||||||
|
|
|
@ -154,7 +154,8 @@ let rec add_expr bv exp =
|
||||||
| Pexp_assertfalse -> ()
|
| Pexp_assertfalse -> ()
|
||||||
| Pexp_lazy (e) -> add_expr bv e
|
| Pexp_lazy (e) -> add_expr bv e
|
||||||
| Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
|
| Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
|
||||||
|
| Pexp_object (pat, fieldl) ->
|
||||||
|
add_pattern bv pat; List.iter (add_class_field bv) fieldl
|
||||||
and add_pat_expr_list bv pel =
|
and add_pat_expr_list bv pel =
|
||||||
List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
|
List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
|
||||||
|
|
||||||
|
|
|
@ -282,6 +282,9 @@ and rw_exp iflag sexp =
|
||||||
|
|
||||||
| Pexp_poly (sexp, _) -> rewrite_exp iflag sexp
|
| Pexp_poly (sexp, _) -> rewrite_exp iflag sexp
|
||||||
|
|
||||||
|
| Pexp_object (_, fieldl) ->
|
||||||
|
List.iter (rewrite_class_field iflag) fieldl
|
||||||
|
|
||||||
and rewrite_ifbody iflag ghost sifbody =
|
and rewrite_ifbody iflag ghost sifbody =
|
||||||
if !instr_if && not ghost then
|
if !instr_if && not ghost then
|
||||||
insert_profile rw_exp sifbody
|
insert_profile rw_exp sifbody
|
||||||
|
|
|
@ -177,6 +177,8 @@ module TypePairs =
|
||||||
|
|
||||||
(**** Object field manipulation. ****)
|
(**** Object field manipulation. ****)
|
||||||
|
|
||||||
|
let dummy_method = "*dummy method*"
|
||||||
|
|
||||||
let object_fields ty =
|
let object_fields ty =
|
||||||
match (repr ty).desc with
|
match (repr ty).desc with
|
||||||
Tobject (fields, _) -> fields
|
Tobject (fields, _) -> fields
|
||||||
|
@ -452,7 +454,7 @@ let closed_class params sign =
|
||||||
List.iter mark_type params;
|
List.iter mark_type params;
|
||||||
mark_type rest;
|
mark_type rest;
|
||||||
List.iter
|
List.iter
|
||||||
(fun (lab, _, ty) -> if lab = "*dummy method*" then mark_type ty)
|
(fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
|
||||||
fields;
|
fields;
|
||||||
try
|
try
|
||||||
mark_type_node (repr sign.cty_self);
|
mark_type_node (repr sign.cty_self);
|
||||||
|
@ -603,13 +605,8 @@ let rec update_level env level ty =
|
||||||
end;
|
end;
|
||||||
set_level ty level;
|
set_level ty level;
|
||||||
iter_type_expr (update_level env level) ty
|
iter_type_expr (update_level env level) ty
|
||||||
| Tfield(_, k, _, _) ->
|
| Tfield(lab, _, _, _) when lab = dummy_method ->
|
||||||
begin match field_kind_repr k with
|
raise (Unify [(ty, newvar2 level)])
|
||||||
Fvar _ (* {contents = None} *) -> raise (Unify [(ty, newvar2 level)])
|
|
||||||
| _ -> ()
|
|
||||||
end;
|
|
||||||
set_level ty level;
|
|
||||||
iter_type_expr (update_level env level) ty
|
|
||||||
| _ ->
|
| _ ->
|
||||||
set_level ty level;
|
set_level ty level;
|
||||||
(* XXX what about abbreviations in Tconstr ? *)
|
(* XXX what about abbreviations in Tconstr ? *)
|
||||||
|
@ -1448,7 +1445,7 @@ and unify3 env t1 t1' t2 t2' =
|
||||||
(* XXX One should do some kind of unification... *)
|
(* XXX One should do some kind of unification... *)
|
||||||
begin match (repr t2').desc with
|
begin match (repr t2').desc with
|
||||||
Tobject (_, {contents = Some (_, va::_)})
|
Tobject (_, {contents = Some (_, va::_)})
|
||||||
when let va = repr va in va.desc = Tvar || va.desc = Tunivar ->
|
when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
|
||||||
()
|
()
|
||||||
| Tobject (_, nm2) ->
|
| Tobject (_, nm2) ->
|
||||||
set_name nm2 !nm1
|
set_name nm2 !nm1
|
||||||
|
@ -1459,6 +1456,11 @@ and unify3 env t1 t1' t2 t2' =
|
||||||
unify_row env row1 row2
|
unify_row env row1 row2
|
||||||
| (Tfield _, Tfield _) -> (* Actually unused *)
|
| (Tfield _, Tfield _) -> (* Actually unused *)
|
||||||
unify_fields env t1' t2'
|
unify_fields env t1' t2'
|
||||||
|
| (Tfield(_,kind,_,rem), Tnil) | (Tnil, Tfield(_,kind,_,rem)) ->
|
||||||
|
begin match field_kind_repr kind with
|
||||||
|
Fvar r -> r := Some Fabsent
|
||||||
|
| _ -> raise (Unify [])
|
||||||
|
end
|
||||||
| (Tnil, Tnil) ->
|
| (Tnil, Tnil) ->
|
||||||
()
|
()
|
||||||
| (Tpoly (t1, []), Tpoly (t2, [])) ->
|
| (Tpoly (t1, []), Tpoly (t2, [])) ->
|
||||||
|
@ -2569,6 +2571,24 @@ let rec filter_visited = function
|
||||||
let memq_warn t visited =
|
let memq_warn t visited =
|
||||||
if List.memq t visited then (warn := true; true) else false
|
if List.memq t visited then (warn := true; true) else false
|
||||||
|
|
||||||
|
let rec lid_of_path sharp = function
|
||||||
|
Path.Pident id ->
|
||||||
|
Longident.Lident (sharp ^ Ident.name id)
|
||||||
|
| Path.Pdot (p1, s, _) ->
|
||||||
|
Longident.Ldot (lid_of_path "" p1, sharp ^ s)
|
||||||
|
| Path.Papply (p1, p2) ->
|
||||||
|
Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
|
||||||
|
|
||||||
|
let find_cltype_for_path env p =
|
||||||
|
let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
|
||||||
|
match cl_abbr.type_manifest with
|
||||||
|
Some ty ->
|
||||||
|
begin match (repr ty).desc with
|
||||||
|
Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
|
||||||
|
| _ -> raise Not_found
|
||||||
|
end
|
||||||
|
| None -> assert false
|
||||||
|
|
||||||
let rec build_subtype env visited loops posi level t =
|
let rec build_subtype env visited loops posi level t =
|
||||||
let t = repr t in
|
let t = repr t in
|
||||||
match t.desc with
|
match t.desc with
|
||||||
|
@ -2604,22 +2624,7 @@ let rec build_subtype env visited loops posi level t =
|
||||||
let level' = pred_expand level in
|
let level' = pred_expand level in
|
||||||
begin try match t'.desc with
|
begin try match t'.desc with
|
||||||
Tobject _ when posi && not (opened_object t') ->
|
Tobject _ when posi && not (opened_object t') ->
|
||||||
let rec lid_of_path sharp = function
|
let cl_abbr, body = find_cltype_for_path env p in
|
||||||
Path.Pident id ->
|
|
||||||
Longident.Lident (sharp ^ Ident.name id)
|
|
||||||
| Path.Pdot (p1, s, _) ->
|
|
||||||
Longident.Ldot (lid_of_path "" p1, sharp ^ s)
|
|
||||||
| Path.Papply (p1, p2) ->
|
|
||||||
Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
|
|
||||||
in
|
|
||||||
let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
|
|
||||||
let body =
|
|
||||||
match cl_abbr.type_manifest with Some ty ->
|
|
||||||
begin match (repr ty).desc with
|
|
||||||
Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> ty
|
|
||||||
| _ -> raise Not_found
|
|
||||||
end
|
|
||||||
| None -> assert false in
|
|
||||||
let ty =
|
let ty =
|
||||||
subst env !current_level abbrev None cl_abbr.type_params tl body in
|
subst env !current_level abbrev None cl_abbr.type_params tl body in
|
||||||
let ty = repr ty in
|
let ty = repr ty in
|
||||||
|
|
|
@ -53,6 +53,7 @@ val none: type_expr
|
||||||
val repr: type_expr -> type_expr
|
val repr: type_expr -> type_expr
|
||||||
(* Return the canonical representative of a type. *)
|
(* Return the canonical representative of a type. *)
|
||||||
|
|
||||||
|
val dummy_method: label
|
||||||
val object_fields: type_expr -> type_expr
|
val object_fields: type_expr -> type_expr
|
||||||
val flatten_fields:
|
val flatten_fields:
|
||||||
type_expr -> (string * field_kind * type_expr) list * type_expr
|
type_expr -> (string * field_kind * type_expr) list * type_expr
|
||||||
|
@ -72,6 +73,7 @@ val set_object_name:
|
||||||
Ident.t -> type_expr -> type_expr list -> type_expr -> unit
|
Ident.t -> type_expr -> type_expr list -> type_expr -> unit
|
||||||
val remove_object_name: type_expr -> unit
|
val remove_object_name: type_expr -> unit
|
||||||
val hide_private_methods: type_expr -> unit
|
val hide_private_methods: type_expr -> unit
|
||||||
|
val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
|
||||||
|
|
||||||
val sort_row_fields: (label * row_field) list -> (label * row_field) list
|
val sort_row_fields: (label * row_field) list -> (label * row_field) list
|
||||||
val merge_row_fields:
|
val merge_row_fields:
|
||||||
|
@ -189,7 +191,7 @@ val match_class_declarations:
|
||||||
|
|
||||||
val enlarge_type: Env.t -> type_expr -> type_expr * bool
|
val enlarge_type: Env.t -> type_expr -> type_expr * bool
|
||||||
(* Make a type larger, flag is true if some pruning had to be done *)
|
(* Make a type larger, flag is true if some pruning had to be done *)
|
||||||
val subtype : Env.t -> type_expr -> type_expr -> unit -> unit
|
val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
|
||||||
(* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
|
(* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
|
||||||
It accumulates the constraints the type variables must
|
It accumulates the constraints the type variables must
|
||||||
enforce and returns a function that inforce this
|
enforce and returns a function that inforce this
|
||||||
|
|
|
@ -88,6 +88,20 @@ let empty = {
|
||||||
cltypes = Ident.empty;
|
cltypes = Ident.empty;
|
||||||
summary = Env_empty }
|
summary = Env_empty }
|
||||||
|
|
||||||
|
let diff_keys tbl1 tbl2 =
|
||||||
|
let keys2 = Ident.keys tbl2 in
|
||||||
|
List.filter
|
||||||
|
(fun id ->
|
||||||
|
match Ident.find_same id tbl2 with Pident _, _ ->
|
||||||
|
(try ignore (Ident.find_same id tbl1); false with Not_found -> true)
|
||||||
|
| _ -> false)
|
||||||
|
keys2
|
||||||
|
|
||||||
|
let diff env1 env2 =
|
||||||
|
diff_keys env1.values env2.values @
|
||||||
|
diff_keys env1.modules env2.modules @
|
||||||
|
diff_keys env1.classes env2.classes
|
||||||
|
|
||||||
(* Forward declarations *)
|
(* Forward declarations *)
|
||||||
|
|
||||||
let components_of_module' =
|
let components_of_module' =
|
||||||
|
|
|
@ -20,6 +20,7 @@ type t
|
||||||
|
|
||||||
val empty: t
|
val empty: t
|
||||||
val initial: t
|
val initial: t
|
||||||
|
val diff: t -> t -> Ident.t list
|
||||||
|
|
||||||
(* Lookup by paths *)
|
(* Lookup by paths *)
|
||||||
|
|
||||||
|
|
|
@ -159,3 +159,14 @@ let rec find_name name = function
|
||||||
k.data
|
k.data
|
||||||
else
|
else
|
||||||
find_name name (if c < 0 then l else r)
|
find_name name (if c < 0 then l else r)
|
||||||
|
|
||||||
|
let rec keys_aux stack accu = function
|
||||||
|
Empty ->
|
||||||
|
begin match stack with
|
||||||
|
[] -> accu
|
||||||
|
| a :: l -> keys_aux l accu a
|
||||||
|
end
|
||||||
|
| Node(l, k, r, _) ->
|
||||||
|
keys_aux (l :: stack) (k.ident :: accu) r
|
||||||
|
|
||||||
|
let keys tbl = keys_aux [] [] tbl
|
||||||
|
|
|
@ -54,3 +54,4 @@ val empty: 'a tbl
|
||||||
val add: t -> 'a -> 'a tbl -> 'a tbl
|
val add: t -> 'a -> 'a tbl -> 'a tbl
|
||||||
val find_same: t -> 'a tbl -> 'a
|
val find_same: t -> 'a tbl -> 'a
|
||||||
val find_name: string -> 'a tbl -> 'a
|
val find_name: string -> 'a tbl -> 'a
|
||||||
|
val keys: 'a tbl -> t list
|
||||||
|
|
|
@ -615,7 +615,7 @@ let class_var sch ppf l (m, t) =
|
||||||
"@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t
|
"@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t
|
||||||
|
|
||||||
let metho sch concrete ppf (lab, kind, ty) =
|
let metho sch concrete ppf (lab, kind, ty) =
|
||||||
if lab <> "*dummy method*" then begin
|
if lab <> dummy_method then begin
|
||||||
let priv =
|
let priv =
|
||||||
match field_kind_repr kind with
|
match field_kind_repr kind with
|
||||||
| Fvar _ (* {contents = None} *) -> "private "
|
| Fvar _ (* {contents = None} *) -> "private "
|
||||||
|
@ -632,7 +632,7 @@ let method_type ty =
|
||||||
| _ -> ty
|
| _ -> ty
|
||||||
|
|
||||||
let tree_of_metho sch concrete csil (lab, kind, ty) =
|
let tree_of_metho sch concrete csil (lab, kind, ty) =
|
||||||
if lab <> "*dummy method*" then begin
|
if lab <> dummy_method then begin
|
||||||
let priv =
|
let priv =
|
||||||
match field_kind_repr kind with
|
match field_kind_repr kind with
|
||||||
| Fvar _ (* {contents = None} *) -> true
|
| Fvar _ (* {contents = None} *) -> true
|
||||||
|
@ -765,7 +765,7 @@ let tree_of_cltype_declaration id cl =
|
||||||
Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
|
Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
|
||||||
List.exists
|
List.exists
|
||||||
(fun (lab, _, ty) ->
|
(fun (lab, _, ty) ->
|
||||||
not (lab = "*dummy method*" || Concr.mem lab sign.cty_concr))
|
not (lab = dummy_method || Concr.mem lab sign.cty_concr))
|
||||||
fields in
|
fields in
|
||||||
|
|
||||||
Osig_class_type
|
Osig_class_type
|
||||||
|
@ -918,8 +918,8 @@ let explanation unif t3 t4 ppf =
|
||||||
| Tvar, Tunivar | Tunivar, Tvar ->
|
| Tvar, Tunivar | Tunivar, Tvar ->
|
||||||
fprintf ppf "@,The universal variable %a would escape its scope"
|
fprintf ppf "@,The universal variable %a would escape its scope"
|
||||||
type_expr (if t3.desc = Tunivar then t3 else t4)
|
type_expr (if t3.desc = Tunivar then t3 else t4)
|
||||||
| Tfield ("*dummy method*", _, _, _), _
|
| Tfield (lab, _, _, _), _
|
||||||
| _, Tfield ("*dummy method*", _, _, _) ->
|
| _, Tfield (lab, _, _, _) when lab = dummy_method ->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@,Self type cannot be unified with a closed object type"
|
"@,Self type cannot be unified with a closed object type"
|
||||||
| Tfield (l, _, _, _), _ ->
|
| Tfield (l, _, _, _), _ ->
|
||||||
|
|
|
@ -48,6 +48,7 @@ type error =
|
||||||
| Cannot_coerce_self of type_expr
|
| Cannot_coerce_self of type_expr
|
||||||
| Non_collapsable_conjunction of
|
| Non_collapsable_conjunction of
|
||||||
Ident.t * Types.class_declaration * (type_expr * type_expr) list
|
Ident.t * Types.class_declaration * (type_expr * type_expr) list
|
||||||
|
| Final_self_clash of (type_expr * type_expr) list
|
||||||
|
|
||||||
exception Error of Location.t * error
|
exception Error of Location.t * error
|
||||||
|
|
||||||
|
@ -61,7 +62,7 @@ exception Error of Location.t * error
|
||||||
Self type have a dummy private method, thus preventing it to become
|
Self type have a dummy private method, thus preventing it to become
|
||||||
closed.
|
closed.
|
||||||
*)
|
*)
|
||||||
let dummy_method = "*dummy method*"
|
let dummy_method = Ctype.dummy_method
|
||||||
|
|
||||||
(*
|
(*
|
||||||
Path associated to the temporary class type of a class being typed
|
Path associated to the temporary class type of a class being typed
|
||||||
|
@ -95,8 +96,7 @@ let rec generalize_class_type =
|
||||||
generalize_class_type cty
|
generalize_class_type cty
|
||||||
|
|
||||||
(* Return the virtual methods of a class type *)
|
(* Return the virtual methods of a class type *)
|
||||||
let virtual_methods cty =
|
let virtual_methods sign =
|
||||||
let sign = Ctype.signature_of_class_type cty in
|
|
||||||
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
|
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
|
||||||
List.fold_left
|
List.fold_left
|
||||||
(fun virt (lab, _, _) ->
|
(fun virt (lab, _, _) ->
|
||||||
|
@ -469,6 +469,7 @@ let rec class_field cl_num self_type meths vars
|
||||||
raise(Error(loc, Method_type_mismatch (lab, trace)))
|
raise(Error(loc, Method_type_mismatch (lab, trace)))
|
||||||
end;
|
end;
|
||||||
let meth_expr = make_method cl_num expr in
|
let meth_expr = make_method cl_num expr in
|
||||||
|
(* backup variables for Pexp_override *)
|
||||||
let vars_local = !vars in
|
let vars_local = !vars in
|
||||||
|
|
||||||
let field =
|
let field =
|
||||||
|
@ -535,28 +536,45 @@ let rec class_field cl_num self_type meths vars
|
||||||
(val_env, met_env, par_env, field::fields,
|
(val_env, met_env, par_env, field::fields,
|
||||||
concr_meths, warn_meths, inh_vals)
|
concr_meths, warn_meths, inh_vals)
|
||||||
|
|
||||||
and class_structure cl_num val_env met_env (spat, str) =
|
and class_structure cl_num final val_env met_env loc (spat, str) =
|
||||||
(* Environment for substructures *)
|
(* Environment for substructures *)
|
||||||
let par_env = met_env in
|
let par_env = met_env in
|
||||||
|
|
||||||
|
(* Private self type more method access, with a dummy method preventing
|
||||||
|
it from being closed/escaped. *)
|
||||||
|
let self_type = Ctype.newvar () in
|
||||||
|
Ctype.unify val_env
|
||||||
|
(Ctype.filter_method val_env dummy_method Private self_type)
|
||||||
|
(Ctype.newty (Ttuple []));
|
||||||
|
|
||||||
(* Self binder *)
|
(* Self binder *)
|
||||||
let (pat, meths, vars, val_env, meth_env, par_env) =
|
let (pat, meths, vars, val_env, meth_env, par_env) =
|
||||||
type_self_pattern cl_num val_env met_env par_env spat
|
type_self_pattern cl_num self_type val_env met_env par_env spat
|
||||||
in
|
in
|
||||||
let self_type = pat.pat_type in
|
let public_self = pat.pat_type in
|
||||||
|
|
||||||
(* Check that the binder has a correct type, and introduce a dummy
|
(* Check that the binder has a correct type *)
|
||||||
method preventing self type from being closed. *)
|
let ty =
|
||||||
let ty = Ctype.newvar () in
|
if final then Ctype.newty (Tobject (Ctype.newvar(), ref None))
|
||||||
Ctype.unify val_env
|
else self_type in
|
||||||
(Ctype.filter_method val_env dummy_method Private ty)
|
begin try Ctype.unify val_env public_self ty with
|
||||||
(Ctype.newty (Ttuple []));
|
|
||||||
begin try Ctype.unify val_env self_type ty with
|
|
||||||
Ctype.Unify _ ->
|
Ctype.Unify _ ->
|
||||||
raise(Error(spat.ppat_loc, Pattern_type_clash self_type))
|
raise(Error(spat.ppat_loc, Pattern_type_clash public_self))
|
||||||
|
end;
|
||||||
|
let get_methods ty =
|
||||||
|
(fst (Ctype.flatten_fields
|
||||||
|
(Ctype.object_fields (Ctype.expand_head val_env ty)))) in
|
||||||
|
if final then begin
|
||||||
|
(* Copy known information to still empty self_type *)
|
||||||
|
List.iter
|
||||||
|
(fun (lab,kind,ty) ->
|
||||||
|
try Ctype.unify val_env ty
|
||||||
|
(Ctype.filter_method val_env lab Public self_type)
|
||||||
|
with _ -> assert false)
|
||||||
|
(get_methods public_self)
|
||||||
end;
|
end;
|
||||||
|
|
||||||
(* Class fields *)
|
(* Typing of class fields *)
|
||||||
let (_, _, _, fields, concr_meths, _, _) =
|
let (_, _, _, fields, concr_meths, _, _) =
|
||||||
List.fold_left (class_field cl_num self_type meths vars)
|
List.fold_left (class_field cl_num self_type meths vars)
|
||||||
(val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
|
(val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
|
||||||
|
@ -564,22 +582,56 @@ and class_structure cl_num val_env met_env (spat, str) =
|
||||||
str
|
str
|
||||||
in
|
in
|
||||||
Ctype.unify val_env self_type (Ctype.newvar ());
|
Ctype.unify val_env self_type (Ctype.newvar ());
|
||||||
let methods =
|
let sign =
|
||||||
if !Clflags.principal then
|
{cty_self = public_self;
|
||||||
fst (Ctype.flatten_fields (Ctype.object_fields self_type))
|
cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
|
||||||
else [] in
|
cty_concr = concr_meths } in
|
||||||
List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
|
let methods = get_methods self_type in
|
||||||
let vars_final = !vars in
|
let priv_meths =
|
||||||
|
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
|
||||||
|
methods in
|
||||||
|
if final then begin
|
||||||
|
(* Unify public_self and a copy of self_type. self_type will not
|
||||||
|
be modified after this point *)
|
||||||
|
Ctype.close_object self_type;
|
||||||
|
let mets = virtual_methods {sign with cty_self = self_type} in
|
||||||
|
if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
|
||||||
|
let self_methods =
|
||||||
|
List.fold_right
|
||||||
|
(fun (lab,kind,ty) rem ->
|
||||||
|
if lab = dummy_method then rem else
|
||||||
|
Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
|
||||||
|
methods (Ctype.newty Tnil) in
|
||||||
|
begin try Ctype.unify val_env public_self
|
||||||
|
(Ctype.newty (Tobject(self_methods, ref None)))
|
||||||
|
with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
(* Typing of method bodies *)
|
||||||
|
if !Clflags.principal then
|
||||||
|
List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
|
||||||
let fields = List.map Lazy.force (List.rev fields) in
|
let fields = List.map Lazy.force (List.rev fields) in
|
||||||
vars := vars_final;
|
if !Clflags.principal then
|
||||||
List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) methods;
|
List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ()))
|
||||||
|
methods;
|
||||||
|
let meths = Meths.map (function (id, ty) -> id) !meths in
|
||||||
|
|
||||||
{cl_field = fields;
|
(* Check for private methods made public *)
|
||||||
cl_meths = Meths.map (function (id, ty) -> id) !meths},
|
let pub_meths' =
|
||||||
|
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
|
||||||
|
(get_methods public_self) in
|
||||||
|
let names = List.map (fun (x,_,_) -> x) in
|
||||||
|
let l1 = names priv_meths and l2 = names pub_meths' in
|
||||||
|
let added = List.filter (fun x -> List.mem x l1) l2 in
|
||||||
|
if added <> [] then
|
||||||
|
Location.prerr_warning loc
|
||||||
|
(Warnings.Other
|
||||||
|
(String.concat " "
|
||||||
|
("the following private methods were made public implicitly:\n "
|
||||||
|
:: added)));
|
||||||
|
|
||||||
{cty_self = self_type;
|
{cl_field = fields; cl_meths = meths}, sign
|
||||||
cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
|
|
||||||
cty_concr = concr_meths }
|
|
||||||
|
|
||||||
and class_expr cl_num val_env met_env scl =
|
and class_expr cl_num val_env met_env scl =
|
||||||
match scl.pcl_desc with
|
match scl.pcl_desc with
|
||||||
|
@ -610,17 +662,21 @@ and class_expr cl_num val_env met_env scl =
|
||||||
let cl =
|
let cl =
|
||||||
rc {cl_desc = Tclass_ident path;
|
rc {cl_desc = Tclass_ident path;
|
||||||
cl_loc = scl.pcl_loc;
|
cl_loc = scl.pcl_loc;
|
||||||
cl_type = clty'}
|
cl_type = clty';
|
||||||
|
cl_env = val_env}
|
||||||
in
|
in
|
||||||
let (vals, meths, concrs) = extract_constraints clty in
|
let (vals, meths, concrs) = extract_constraints clty in
|
||||||
rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
|
rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
|
||||||
cl_loc = scl.pcl_loc;
|
cl_loc = scl.pcl_loc;
|
||||||
cl_type = clty'}
|
cl_type = clty';
|
||||||
|
cl_env = val_env}
|
||||||
| Pcl_structure cl_str ->
|
| Pcl_structure cl_str ->
|
||||||
let (desc, ty) = class_structure cl_num val_env met_env cl_str in
|
let (desc, ty) =
|
||||||
|
class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
|
||||||
rc {cl_desc = Tclass_structure desc;
|
rc {cl_desc = Tclass_structure desc;
|
||||||
cl_loc = scl.pcl_loc;
|
cl_loc = scl.pcl_loc;
|
||||||
cl_type = Tcty_signature ty}
|
cl_type = Tcty_signature ty;
|
||||||
|
cl_env = val_env}
|
||||||
| Pcl_fun (l, Some default, spat, sbody) ->
|
| Pcl_fun (l, Some default, spat, sbody) ->
|
||||||
let loc = default.pexp_loc in
|
let loc = default.pexp_loc in
|
||||||
let scases =
|
let scases =
|
||||||
|
@ -682,7 +738,8 @@ and class_expr cl_num val_env met_env scl =
|
||||||
(Warnings.Other "This optional argument cannot be erased");
|
(Warnings.Other "This optional argument cannot be erased");
|
||||||
rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
|
rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
|
||||||
cl_loc = scl.pcl_loc;
|
cl_loc = scl.pcl_loc;
|
||||||
cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type)}
|
cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
|
||||||
|
cl_env = val_env}
|
||||||
| Pcl_apply (scl', sargs) ->
|
| Pcl_apply (scl', sargs) ->
|
||||||
let cl = class_expr cl_num val_env met_env scl' in
|
let cl = class_expr cl_num val_env met_env scl' in
|
||||||
let rec nonopt_labels ls ty_fun =
|
let rec nonopt_labels ls ty_fun =
|
||||||
|
@ -769,7 +826,8 @@ and class_expr cl_num val_env met_env scl =
|
||||||
in
|
in
|
||||||
rc {cl_desc = Tclass_apply (cl, args);
|
rc {cl_desc = Tclass_apply (cl, args);
|
||||||
cl_loc = scl.pcl_loc;
|
cl_loc = scl.pcl_loc;
|
||||||
cl_type = cty}
|
cl_type = cty;
|
||||||
|
cl_env = val_env}
|
||||||
| Pcl_let (rec_flag, sdefs, scl') ->
|
| Pcl_let (rec_flag, sdefs, scl') ->
|
||||||
let (defs, val_env) =
|
let (defs, val_env) =
|
||||||
try
|
try
|
||||||
|
@ -802,7 +860,8 @@ and class_expr cl_num val_env met_env scl =
|
||||||
let cl = class_expr cl_num val_env met_env scl' in
|
let cl = class_expr cl_num val_env met_env scl' in
|
||||||
rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
|
rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
|
||||||
cl_loc = scl.pcl_loc;
|
cl_loc = scl.pcl_loc;
|
||||||
cl_type = cl.cl_type}
|
cl_type = cl.cl_type;
|
||||||
|
cl_env = val_env}
|
||||||
| Pcl_constraint (scl', scty) ->
|
| Pcl_constraint (scl', scty) ->
|
||||||
Ctype.begin_class_def ();
|
Ctype.begin_class_def ();
|
||||||
let context = Typetexp.narrow () in
|
let context = Typetexp.narrow () in
|
||||||
|
@ -824,7 +883,8 @@ and class_expr cl_num val_env met_env scl =
|
||||||
let (vals, meths, concrs) = extract_constraints clty in
|
let (vals, meths, concrs) = extract_constraints clty in
|
||||||
rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
|
rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
|
||||||
cl_loc = scl.pcl_loc;
|
cl_loc = scl.pcl_loc;
|
||||||
cl_type = snd (Ctype.instance_class [] clty)}
|
cl_type = snd (Ctype.instance_class [] clty);
|
||||||
|
cl_env = val_env}
|
||||||
|
|
||||||
(*******************************)
|
(*******************************)
|
||||||
|
|
||||||
|
@ -1034,7 +1094,7 @@ let class_infos define_class kind
|
||||||
in
|
in
|
||||||
|
|
||||||
if cl.pci_virt = Concrete then begin
|
if cl.pci_virt = Concrete then begin
|
||||||
match virtual_methods typ with
|
match virtual_methods (Ctype.signature_of_class_type typ) with
|
||||||
[] -> ()
|
[] -> ()
|
||||||
| mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
|
| mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
|
||||||
end;
|
end;
|
||||||
|
@ -1149,10 +1209,13 @@ let merge_type_decls
|
||||||
let final_env define_class env
|
let final_env define_class env
|
||||||
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
|
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
|
||||||
arity, pub_meths, coe, expr) =
|
arity, pub_meths, coe, expr) =
|
||||||
Env.add_type obj_id obj_abbr (
|
(* Add definitions after cleaning them *)
|
||||||
Env.add_type cl_id cl_abbr (
|
Env.add_type obj_id (Subst.type_declaration Subst.identity obj_abbr) (
|
||||||
Env.add_cltype ty_id cltydef (
|
Env.add_type cl_id (Subst.type_declaration Subst.identity cl_abbr) (
|
||||||
if define_class then Env.add_class id clty env else env)))
|
Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
|
||||||
|
if define_class then
|
||||||
|
Env.add_class id (Subst.class_declaration Subst.identity clty) env
|
||||||
|
else env)))
|
||||||
|
|
||||||
(* Check that #c is coercible to c if there is a self-coercion *)
|
(* Check that #c is coercible to c if there is a self-coercion *)
|
||||||
let check_coercions env
|
let check_coercions env
|
||||||
|
@ -1237,6 +1300,40 @@ let class_type_declarations env cls =
|
||||||
decl,
|
decl,
|
||||||
env)
|
env)
|
||||||
|
|
||||||
|
let rec unify_parents env ty cl =
|
||||||
|
match cl.cl_desc with
|
||||||
|
Tclass_ident p ->
|
||||||
|
begin try
|
||||||
|
let decl = Env.find_class p env in
|
||||||
|
let _, body = Ctype.find_cltype_for_path env decl.cty_path in
|
||||||
|
Ctype.unify env ty (Ctype.instance body)
|
||||||
|
with exn -> assert (exn = Not_found)
|
||||||
|
end
|
||||||
|
| Tclass_structure st -> unify_parents_struct env ty st
|
||||||
|
| Tclass_fun (_, _, cl, _)
|
||||||
|
| Tclass_apply (cl, _)
|
||||||
|
| Tclass_let (_, _, _, cl)
|
||||||
|
| Tclass_constraint (cl, _, _, _) -> unify_parents env ty cl
|
||||||
|
and unify_parents_struct env ty st =
|
||||||
|
List.iter
|
||||||
|
(function Cf_inher (cl, _, _) -> unify_parents env ty cl
|
||||||
|
| _ -> ())
|
||||||
|
st.cl_field
|
||||||
|
|
||||||
|
let type_object env loc s =
|
||||||
|
incr class_num;
|
||||||
|
let (desc, sign) =
|
||||||
|
class_structure (string_of_int !class_num) true env env loc s in
|
||||||
|
let sty = Ctype.expand_head env sign.cty_self in
|
||||||
|
Ctype.hide_private_methods sty;
|
||||||
|
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
|
||||||
|
let meths = List.map (fun (s,_,_) -> s) fields in
|
||||||
|
unify_parents_struct env sign.cty_self desc;
|
||||||
|
(desc, sign, meths)
|
||||||
|
|
||||||
|
let () =
|
||||||
|
Typecore.type_object := type_object
|
||||||
|
|
||||||
(*******************************)
|
(*******************************)
|
||||||
|
|
||||||
(* Approximate the class declaration as class ['params] id = object end *)
|
(* Approximate the class declaration as class ['params] id = object end *)
|
||||||
|
@ -1318,9 +1415,9 @@ let report_error ppf = function
|
||||||
| Virtual_class (cl, mets) ->
|
| Virtual_class (cl, mets) ->
|
||||||
let print_mets ppf mets =
|
let print_mets ppf mets =
|
||||||
List.iter (function met -> fprintf ppf "@ %s" met) mets in
|
List.iter (function met -> fprintf ppf "@ %s" met) mets in
|
||||||
let cl_mark = if cl then " type" else "" in
|
let cl_mark = if cl then "" else " type" in
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[This class %s should be virtual@ \
|
"@[This class%s should be virtual@ \
|
||||||
@[<2>The following methods are undefined :%a@]
|
@[<2>The following methods are undefined :%a@]
|
||||||
@]"
|
@]"
|
||||||
cl_mark print_mets mets
|
cl_mark print_mets mets
|
||||||
|
@ -1390,3 +1487,9 @@ let report_error ppf = function
|
||||||
Printtyp.report_unification_error ppf trace
|
Printtyp.report_unification_error ppf trace
|
||||||
(fun ppf -> fprintf ppf "Type")
|
(fun ppf -> fprintf ppf "Type")
|
||||||
(fun ppf -> fprintf ppf "is not compatible with type")
|
(fun ppf -> fprintf ppf "is not compatible with type")
|
||||||
|
| Final_self_clash trace ->
|
||||||
|
Printtyp.report_unification_error ppf trace
|
||||||
|
(function ppf ->
|
||||||
|
fprintf ppf "This object is expected to have type")
|
||||||
|
(function ppf ->
|
||||||
|
fprintf ppf "but has actually type")
|
||||||
|
|
|
@ -71,6 +71,7 @@ type error =
|
||||||
| Cannot_coerce_self of type_expr
|
| Cannot_coerce_self of type_expr
|
||||||
| Non_collapsable_conjunction of
|
| Non_collapsable_conjunction of
|
||||||
Ident.t * Types.class_declaration * (type_expr * type_expr) list
|
Ident.t * Types.class_declaration * (type_expr * type_expr) list
|
||||||
|
| Final_self_clash of (type_expr * type_expr) list
|
||||||
|
|
||||||
exception Error of Location.t * error
|
exception Error of Location.t * error
|
||||||
|
|
||||||
|
|
|
@ -67,6 +67,11 @@ let type_module =
|
||||||
ref ((fun env md -> assert false) :
|
ref ((fun env md -> assert false) :
|
||||||
Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
|
Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
|
||||||
|
|
||||||
|
(* Forward declaration, to be filled in by Typeclass.class_structure *)
|
||||||
|
let type_object =
|
||||||
|
ref (fun env s -> assert false :
|
||||||
|
Env.t -> Location.t -> Parsetree.class_structure ->
|
||||||
|
class_structure * class_signature * string list)
|
||||||
|
|
||||||
(*
|
(*
|
||||||
Saving and outputting type information.
|
Saving and outputting type information.
|
||||||
|
@ -523,7 +528,8 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
|
||||||
(pat, pv, val_env, met_env)
|
(pat, pv, val_env, met_env)
|
||||||
|
|
||||||
let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
|
let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
|
||||||
let type_self_pattern cl_num val_env met_env par_env spat =
|
|
||||||
|
let type_self_pattern cl_num privty val_env met_env par_env spat =
|
||||||
let spat =
|
let spat =
|
||||||
mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
|
mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
|
||||||
"selfpat-" ^ cl_num))
|
"selfpat-" ^ cl_num))
|
||||||
|
@ -540,7 +546,7 @@ let type_self_pattern cl_num val_env met_env par_env spat =
|
||||||
(fun (id, ty) (val_env, met_env, par_env) ->
|
(fun (id, ty) (val_env, met_env, par_env) ->
|
||||||
(Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
|
(Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
|
||||||
Env.add_value id {val_type = ty;
|
Env.add_value id {val_type = ty;
|
||||||
val_kind = Val_self (meths, vars, cl_num)}
|
val_kind = Val_self (meths, vars, cl_num, privty)}
|
||||||
met_env,
|
met_env,
|
||||||
Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
|
Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
|
||||||
pv (val_env, met_env, par_env)
|
pv (val_env, met_env, par_env)
|
||||||
|
@ -583,7 +589,20 @@ let rec is_nonexpansive exp =
|
||||||
is_nonexpansive ifso && is_nonexpansive_opt ifnot
|
is_nonexpansive ifso && is_nonexpansive_opt ifnot
|
||||||
| Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
|
| Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
|
||||||
true
|
true
|
||||||
| Texp_lazy e -> true
|
(* Note: nonexpansive only means no _observable_ side effects *)
|
||||||
|
| Texp_lazy e -> is_nonexpansive e
|
||||||
|
| Texp_object ({cl_field=fields}, {cty_vars=vars}, _) ->
|
||||||
|
let count = ref 0 in
|
||||||
|
List.for_all
|
||||||
|
(function
|
||||||
|
Cf_meth _ -> true
|
||||||
|
| Cf_val (_,_,e) -> incr count; is_nonexpansive e
|
||||||
|
| Cf_init e -> is_nonexpansive e
|
||||||
|
| Cf_inher _ | Cf_let _ -> false)
|
||||||
|
fields &&
|
||||||
|
Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
|
||||||
|
vars true &&
|
||||||
|
!count = 0
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
and is_nonexpansive_opt = function
|
and is_nonexpansive_opt = function
|
||||||
|
@ -796,7 +815,7 @@ let rec type_exp env sexp =
|
||||||
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
|
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
|
||||||
in
|
in
|
||||||
Texp_instvar(self_path, path)
|
Texp_instvar(self_path, path)
|
||||||
| Val_self (_, _, cl_num) ->
|
| Val_self (_, _, cl_num, _) ->
|
||||||
let (path, _) =
|
let (path, _) =
|
||||||
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
|
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
|
||||||
in
|
in
|
||||||
|
@ -1123,9 +1142,9 @@ let rec type_exp env sexp =
|
||||||
begin try
|
begin try
|
||||||
let (exp, typ) =
|
let (exp, typ) =
|
||||||
match obj.exp_desc with
|
match obj.exp_desc with
|
||||||
Texp_ident(path, {val_kind = Val_self (meths, _, _)}) ->
|
Texp_ident(path, {val_kind = Val_self (meths, _, _, privty)}) ->
|
||||||
let (id, typ) =
|
let (id, typ) =
|
||||||
filter_self_method env met Private meths obj.exp_type
|
filter_self_method env met Private meths privty
|
||||||
in
|
in
|
||||||
(Texp_send(obj, Tmeth_val id), typ)
|
(Texp_send(obj, Tmeth_val id), typ)
|
||||||
| Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
|
| Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
|
||||||
|
@ -1138,10 +1157,10 @@ let rec type_exp env sexp =
|
||||||
Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
|
Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
|
||||||
Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
|
Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
|
||||||
with
|
with
|
||||||
(_, ({val_kind = Val_self (meths, _, _)} as desc)),
|
(_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
|
||||||
(path, _) ->
|
(path, _) ->
|
||||||
let (_, typ) =
|
let (_, typ) =
|
||||||
filter_self_method env met Private meths obj.exp_type
|
filter_self_method env met Private meths privty
|
||||||
in
|
in
|
||||||
let method_type = newvar () in
|
let method_type = newvar () in
|
||||||
let (obj_ty, res_ty) = filter_arrow env method_type "" in
|
let (obj_ty, res_ty) = filter_arrow env method_type "" in
|
||||||
|
@ -1251,7 +1270,7 @@ let rec type_exp env sexp =
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
raise(Error(sexp.pexp_loc, Outside_class))
|
raise(Error(sexp.pexp_loc, Outside_class))
|
||||||
with
|
with
|
||||||
(_, {val_type = self_ty; val_kind = Val_self (_, vars, _)}),
|
(_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
|
||||||
(path_self, _) ->
|
(path_self, _) ->
|
||||||
let type_override (lab, snewval) =
|
let type_override (lab, snewval) =
|
||||||
begin try
|
begin try
|
||||||
|
@ -1318,6 +1337,14 @@ let rec type_exp env sexp =
|
||||||
exp_type = instance (Predef.type_lazy_t arg.exp_type);
|
exp_type = instance (Predef.type_lazy_t arg.exp_type);
|
||||||
exp_env = env;
|
exp_env = env;
|
||||||
}
|
}
|
||||||
|
| Pexp_object s ->
|
||||||
|
let desc, sign, meths = !type_object env sexp.pexp_loc s in
|
||||||
|
re {
|
||||||
|
exp_desc = Texp_object (desc, sign, meths);
|
||||||
|
exp_loc = sexp.pexp_loc;
|
||||||
|
exp_type = sign.cty_self;
|
||||||
|
exp_env = env;
|
||||||
|
}
|
||||||
| Pexp_poly _ ->
|
| Pexp_poly _ ->
|
||||||
assert false
|
assert false
|
||||||
|
|
||||||
|
|
|
@ -35,7 +35,7 @@ val type_class_arg_pattern:
|
||||||
Typedtree.pattern * (Ident.t * Ident.t * type_expr) list *
|
Typedtree.pattern * (Ident.t * Ident.t * type_expr) list *
|
||||||
Env.t * Env.t
|
Env.t * Env.t
|
||||||
val type_self_pattern:
|
val type_self_pattern:
|
||||||
string -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
|
string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
|
||||||
Typedtree.pattern *
|
Typedtree.pattern *
|
||||||
(Ident.t * type_expr) Meths.t ref *
|
(Ident.t * type_expr) Meths.t ref *
|
||||||
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
|
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
|
||||||
|
@ -102,3 +102,7 @@ val report_error: formatter -> error -> unit
|
||||||
|
|
||||||
(* Forward declaration, to be filled in by Typemod.type_module *)
|
(* Forward declaration, to be filled in by Typemod.type_module *)
|
||||||
val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
|
val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
|
||||||
|
(* Forward declaration, to be filled in by Typeclass.class_structure *)
|
||||||
|
val type_object:
|
||||||
|
(Env.t -> Location.t -> Parsetree.class_structure ->
|
||||||
|
Typedtree.class_structure * class_signature * string list) ref
|
||||||
|
|
|
@ -77,6 +77,7 @@ and expression_desc =
|
||||||
| Texp_assert of expression
|
| Texp_assert of expression
|
||||||
| Texp_assertfalse
|
| Texp_assertfalse
|
||||||
| Texp_lazy of expression
|
| Texp_lazy of expression
|
||||||
|
| Texp_object of class_structure * class_signature * string list
|
||||||
|
|
||||||
and meth =
|
and meth =
|
||||||
Tmeth_name of string
|
Tmeth_name of string
|
||||||
|
@ -87,7 +88,8 @@ and meth =
|
||||||
and class_expr =
|
and class_expr =
|
||||||
{ cl_desc: class_expr_desc;
|
{ cl_desc: class_expr_desc;
|
||||||
cl_loc: Location.t;
|
cl_loc: Location.t;
|
||||||
cl_type: class_type }
|
cl_type: class_type;
|
||||||
|
cl_env: Env.t }
|
||||||
|
|
||||||
and class_expr_desc =
|
and class_expr_desc =
|
||||||
Tclass_ident of Path.t
|
Tclass_ident of Path.t
|
||||||
|
|
|
@ -76,6 +76,7 @@ and expression_desc =
|
||||||
| Texp_assert of expression
|
| Texp_assert of expression
|
||||||
| Texp_assertfalse
|
| Texp_assertfalse
|
||||||
| Texp_lazy of expression
|
| Texp_lazy of expression
|
||||||
|
| Texp_object of class_structure * class_signature * string list
|
||||||
|
|
||||||
and meth =
|
and meth =
|
||||||
Tmeth_name of string
|
Tmeth_name of string
|
||||||
|
@ -86,7 +87,8 @@ and meth =
|
||||||
and class_expr =
|
and class_expr =
|
||||||
{ cl_desc: class_expr_desc;
|
{ cl_desc: class_expr_desc;
|
||||||
cl_loc: Location.t;
|
cl_loc: Location.t;
|
||||||
cl_type: class_type }
|
cl_type: class_type;
|
||||||
|
cl_env: Env.t }
|
||||||
|
|
||||||
and class_expr_desc =
|
and class_expr_desc =
|
||||||
Tclass_ident of Path.t
|
Tclass_ident of Path.t
|
||||||
|
|
|
@ -91,7 +91,7 @@ and value_kind =
|
||||||
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
|
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
|
||||||
| Val_self of (Ident.t * type_expr) Meths.t ref *
|
| Val_self of (Ident.t * type_expr) Meths.t ref *
|
||||||
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
|
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
|
||||||
string
|
string * type_expr
|
||||||
(* Self *)
|
(* Self *)
|
||||||
| Val_anc of (string * Ident.t) list * string
|
| Val_anc of (string * Ident.t) list * string
|
||||||
(* Ancestor *)
|
(* Ancestor *)
|
||||||
|
|
|
@ -92,7 +92,7 @@ and value_kind =
|
||||||
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
|
| Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
|
||||||
| Val_self of (Ident.t * type_expr) Meths.t ref *
|
| Val_self of (Ident.t * type_expr) Meths.t ref *
|
||||||
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
|
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
|
||||||
string
|
string * type_expr
|
||||||
(* Self *)
|
(* Self *)
|
||||||
| Val_anc of (string * Ident.t) list * string
|
| Val_anc of (string * Ident.t) list * string
|
||||||
(* Ancestor *)
|
(* Ancestor *)
|
||||||
|
|
Loading…
Reference in New Issue