|
@@ -1479,6 +1479,31 @@ let init_core_api ctx c =
|
|
|
| None, Some { cf_public = false } -> ()
|
|
| None, Some { cf_public = false } -> ()
|
|
|
| _ -> error "Constructor differs from core type" c.cl_pos)
|
|
| _ -> error "Constructor differs from core type" c.cl_pos)
|
|
|
|
|
|
|
|
|
|
+let check_global_metadata ctx f_add mpath tpath so =
|
|
|
|
|
+ let sl1 = if mpath = tpath then
|
|
|
|
|
+ (fst tpath) @ [snd tpath]
|
|
|
|
|
+ else
|
|
|
|
|
+ (fst mpath) @ [snd mpath;snd tpath]
|
|
|
|
|
+ in
|
|
|
|
|
+ let sl1,field_mode = match so with None -> sl1,false | Some s -> sl1 @ [s],true in
|
|
|
|
|
+ List.iter (fun (sl2,m,(recursive,to_types,to_fields)) ->
|
|
|
|
|
+ let rec loop sl1 sl2 = match sl1,sl2 with
|
|
|
|
|
+ | [],[] ->
|
|
|
|
|
+ true
|
|
|
|
|
+ (* always recurse into types of package paths *)
|
|
|
|
|
+ | (s1 :: s11 :: _),[s2] when is_lower_ident s2 && not (is_lower_ident s11)->
|
|
|
|
|
+ s1 = s2
|
|
|
|
|
+ | _,[] ->
|
|
|
|
|
+ recursive
|
|
|
|
|
+ | [],_ ->
|
|
|
|
|
+ false
|
|
|
|
|
+ | (s1 :: sl1),(s2 :: sl2) ->
|
|
|
|
|
+ s1 = s2 && loop sl1 sl2
|
|
|
|
|
+ in
|
|
|
|
|
+ let add = ((field_mode && to_fields) || (not field_mode && to_types)) && (sl2 = [""] || loop sl1 sl2) in
|
|
|
|
|
+ if add then f_add m
|
|
|
|
|
+ ) ctx.g.global_metadata
|
|
|
|
|
+
|
|
|
let patch_class ctx c fields =
|
|
let patch_class ctx c fields =
|
|
|
let h = (try Some (Hashtbl.find ctx.g.type_patches c.cl_path) with Not_found -> None) in
|
|
let h = (try Some (Hashtbl.find ctx.g.type_patches c.cl_path) with Not_found -> None) in
|
|
|
match h with
|
|
match h with
|
|
@@ -1808,6 +1833,7 @@ let init_class ctx c p context_init herits fields =
|
|
|
|
|
|
|
|
let loop_cf f =
|
|
let loop_cf f =
|
|
|
let name = f.cff_name in
|
|
let name = f.cff_name in
|
|
|
|
|
+ check_global_metadata ctx (fun m -> f.cff_meta <- m :: f.cff_meta) c.cl_module.m_path c.cl_path (Some name);
|
|
|
let p = f.cff_pos in
|
|
let p = f.cff_pos in
|
|
|
if name.[0] = '$' && ctx.com.display = DMNone then error "Field names starting with a dollar are not allowed" p;
|
|
if name.[0] = '$' && ctx.com.display = DMNone then error "Field names starting with a dollar are not allowed" p;
|
|
|
let stat = List.mem AStatic f.cff_access in
|
|
let stat = List.mem AStatic f.cff_access in
|
|
@@ -2468,6 +2494,7 @@ let rec init_module_type ctx context_init do_init (decl,p) =
|
|
|
context_init := (fun() -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using) :: !context_init
|
|
context_init := (fun() -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using) :: !context_init
|
|
|
| EClass d ->
|
|
| EClass d ->
|
|
|
let c = (match get_type d.d_name with TClassDecl c -> c | _ -> assert false) in
|
|
let c = (match get_type d.d_name with TClassDecl c -> c | _ -> assert false) in
|
|
|
|
|
+ check_global_metadata ctx (fun m -> c.cl_meta <- m :: c.cl_meta) c.cl_module.m_path c.cl_path None;
|
|
|
let herits = d.d_flags in
|
|
let herits = d.d_flags in
|
|
|
if Meta.has Meta.Generic c.cl_meta && c.cl_params <> [] then c.cl_kind <- KGeneric;
|
|
if Meta.has Meta.Generic c.cl_meta && c.cl_params <> [] then c.cl_kind <- KGeneric;
|
|
|
if Meta.has Meta.GenericBuild c.cl_meta then c.cl_kind <- KGenericBuild d.d_data;
|
|
if Meta.has Meta.GenericBuild c.cl_meta then c.cl_kind <- KGenericBuild d.d_data;
|
|
@@ -2489,6 +2516,7 @@ let rec init_module_type ctx context_init do_init (decl,p) =
|
|
|
let e = (match get_type d.d_name with TEnumDecl e -> e | _ -> assert false) in
|
|
let e = (match get_type d.d_name with TEnumDecl e -> e | _ -> assert false) in
|
|
|
let ctx = { ctx with type_params = e.e_params } in
|
|
let ctx = { ctx with type_params = e.e_params } in
|
|
|
let h = (try Some (Hashtbl.find ctx.g.type_patches e.e_path) with Not_found -> None) in
|
|
let h = (try Some (Hashtbl.find ctx.g.type_patches e.e_path) with Not_found -> None) in
|
|
|
|
|
+ check_global_metadata ctx (fun m -> e.e_meta <- m :: e.e_meta) e.e_module.m_path e.e_path None;
|
|
|
(match h with
|
|
(match h with
|
|
|
| None -> ()
|
|
| None -> ()
|
|
|
| Some (h,hcl) ->
|
|
| Some (h,hcl) ->
|
|
@@ -2608,6 +2636,7 @@ let rec init_module_type ctx context_init do_init (decl,p) =
|
|
|
if !is_flat then e.e_meta <- (Meta.FlatEnum,[],e.e_pos) :: e.e_meta;
|
|
if !is_flat then e.e_meta <- (Meta.FlatEnum,[],e.e_pos) :: e.e_meta;
|
|
|
| ETypedef d ->
|
|
| ETypedef d ->
|
|
|
let t = (match get_type d.d_name with TTypeDecl t -> t | _ -> assert false) in
|
|
let t = (match get_type d.d_name with TTypeDecl t -> t | _ -> assert false) in
|
|
|
|
|
+ check_global_metadata ctx (fun m -> t.t_meta <- m :: t.t_meta) t.t_module.m_path t.t_path None;
|
|
|
let ctx = { ctx with type_params = t.t_params } in
|
|
let ctx = { ctx with type_params = t.t_params } in
|
|
|
let tt = load_complex_type ctx p d.d_data in
|
|
let tt = load_complex_type ctx p d.d_data in
|
|
|
(*
|
|
(*
|
|
@@ -2625,6 +2654,7 @@ let rec init_module_type ctx context_init do_init (decl,p) =
|
|
|
| _ -> assert false);
|
|
| _ -> assert false);
|
|
|
| EAbstract d ->
|
|
| EAbstract d ->
|
|
|
let a = (match get_type d.d_name with TAbstractDecl a -> a | _ -> assert false) in
|
|
let a = (match get_type d.d_name with TAbstractDecl a -> a | _ -> assert false) in
|
|
|
|
|
+ check_global_metadata ctx (fun m -> a.a_meta <- m :: a.a_meta) a.a_module.m_path a.a_path None;
|
|
|
let ctx = { ctx with type_params = a.a_params } in
|
|
let ctx = { ctx with type_params = a.a_params } in
|
|
|
let is_type = ref false in
|
|
let is_type = ref false in
|
|
|
let load_type t from =
|
|
let load_type t from =
|