From 2d7bc8ee6cd34b1816bd75d05e252617d6aebd15 Mon Sep 17 00:00:00 2001 From: Dan Korostelev Date: Thu, 20 Jun 2019 23:16:25 +0200 Subject: [PATCH] start working on module-level functions --- src/codegen/gencommon/gencommon.ml | 6 ++-- src/context/typecore.ml | 1 + src/core/ast.ml | 1 + src/core/tFunctions.ml | 1 + src/core/tType.ml | 2 ++ src/syntax/grammar.mly | 22 ++++++++++++ src/syntax/parser.ml | 5 +++ src/typing/generic.ml | 2 ++ src/typing/typeloadFields.ml | 2 +- src/typing/typeloadModule.ml | 56 +++++++++++++++++++++++++++++- src/typing/typer.ml | 9 +++++ 11 files changed, 102 insertions(+), 5 deletions(-) diff --git a/src/codegen/gencommon/gencommon.ml b/src/codegen/gencommon/gencommon.ml index d4e5e687449..83e63538011 100644 --- a/src/codegen/gencommon/gencommon.ml +++ b/src/codegen/gencommon/gencommon.ml @@ -617,11 +617,11 @@ let new_ctx con = gadd_type = (fun md should_filter -> if should_filter then begin gen.gtypes_list <- md :: gen.gtypes_list; - gen.gmodules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake [] } :: gen.gmodules; + gen.gmodules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_statics = None; m_extra = module_extra "" "" 0. MFake [] } :: gen.gmodules; Hashtbl.add gen.gtypes (t_path md) md; end else gen.gafter_filters_ended <- (fun () -> gen.gtypes_list <- md :: gen.gtypes_list; - gen.gmodules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_extra = module_extra "" "" 0. MFake [] } :: gen.gmodules; + gen.gmodules <- { m_id = alloc_mid(); m_path = (t_path md); m_types = [md]; m_statics = None; m_extra = module_extra "" "" 0. MFake [] } :: gen.gmodules; Hashtbl.add gen.gtypes (t_path md) md; ) :: gen.gafter_filters_ended; ); @@ -682,7 +682,7 @@ let reorder_modules gen = Hashtbl.iter (fun md_path md -> if not (Hashtbl.mem processed md_path) then begin Hashtbl.add processed md_path true; - gen.gmodules <- { m_id = alloc_mid(); m_path = md_path; m_types = List.rev ( Hashtbl.find_all modules md_path ); m_extra = (t_infos md).mt_module.m_extra } :: gen.gmodules + gen.gmodules <- { m_id = alloc_mid(); m_path = md_path; m_types = List.rev ( Hashtbl.find_all modules md_path ); m_statics = None; m_extra = (t_infos md).mt_module.m_extra } :: gen.gmodules end ) modules diff --git a/src/context/typecore.ml b/src/context/typecore.ml index da9b7ef59d5..dd3fe04cc1f 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -353,6 +353,7 @@ let create_fake_module ctx file = m_id = alloc_mid(); m_path = (["$DEP"],file); m_types = []; + m_statics = None; m_extra = module_extra file (Define.get_signature ctx.com.defines) (file_time file) MFake []; } in Hashtbl.add fake_modules file mdep; diff --git a/src/core/ast.ml b/src/core/ast.ml index 89e46b24170..4ae67cc0baf 100644 --- a/src/core/ast.ml +++ b/src/core/ast.ml @@ -321,6 +321,7 @@ type type_def = | EEnum of (enum_flag, enum_constructor list) definition | ETypedef of (enum_flag, type_hint) definition | EAbstract of (abstract_flag, class_field list) definition + | EGlobal of (placed_access, class_field_kind) definition | EImport of import | EUsing of placed_name list diff --git a/src/core/tFunctions.ml b/src/core/tFunctions.ml index c462568ae43..f42fc5ca41f 100644 --- a/src/core/tFunctions.ml +++ b/src/core/tFunctions.ml @@ -151,6 +151,7 @@ let null_module = { m_id = alloc_mid(); m_path = [] , ""; m_types = []; + m_statics = None; m_extra = module_extra "" "" 0. MFake []; } diff --git a/src/core/tType.ml b/src/core/tType.ml index 0fa9131ce09..90cd6a6c4fb 100644 --- a/src/core/tType.ml +++ b/src/core/tType.ml @@ -185,6 +185,7 @@ and tclass_kind = | KMacroType | KGenericBuild of class_field list | KAbstractImpl of tabstract + | KModuleStatics of module_def and metadata = Ast.metadata @@ -312,6 +313,7 @@ and module_def = { m_id : int; m_path : path; mutable m_types : module_type list; + mutable m_statics : tclass option; m_extra : module_def_extra; } diff --git a/src/syntax/grammar.mly b/src/syntax/grammar.mly index 0ab62323a1d..3c9b80a84d6 100644 --- a/src/syntax/grammar.mly +++ b/src/syntax/grammar.mly @@ -169,6 +169,28 @@ and parse_type_decl mode s = | [< '(Kwd Using,p1) >] -> parse_using s p1 | [< doc = get_doc; meta = parse_meta; c = parse_common_flags; s >] -> match s with parser + | [< '(Kwd Function,p1); name = dollar_ident; pl = parse_constraint_params; '(POpen,_); args = psep Comma parse_fun_param; '(PClose,_); t = popt parse_type_hint; s >] -> + let e, p2 = (match s with parser + | [< e = expr; s >] -> + ignore(semicolon s); + Some e, pos e + | [< p = semicolon >] -> None, p + | [< >] -> serror() + ) in + let f = { + f_params = pl; + f_args = args; + f_type = t; + f_expr = e; + } in + (EGlobal { + d_name = name; + d_doc = doc_from_string_opt doc; + d_meta = meta; + d_params = pl; + d_flags = List.map decl_flag_to_global_flag c; + d_data = FFun f; + }, punion p1 p2) | [< '(Kwd Enum,p1) >] -> begin match s with parser | [< a,p = parse_abstract doc ((Meta.Enum,[],null_pos) :: meta) c >] -> diff --git a/src/syntax/parser.ml b/src/syntax/parser.ml index 7af90ad7983..d6079cb6f3e 100644 --- a/src/syntax/parser.ml +++ b/src/syntax/parser.ml @@ -104,6 +104,11 @@ let decl_flag_to_abstract_flag (flag,p) = match flag with | DExtern -> AbExtern | DFinal -> error (Custom "final on abstracts is not allowed") p +let decl_flag_to_global_flag (flag,p) = match flag with + | DPrivate -> (APrivate,p) + | DExtern -> (AExtern,p) + | DFinal -> (AFinal,p) + module TokenCache = struct let cache = ref (DynArray.create ()) let add (token : (token * pos)) = DynArray.add (!cache) token diff --git a/src/typing/generic.ml b/src/typing/generic.ml index f539f96046c..00775350f28 100644 --- a/src/typing/generic.ml +++ b/src/typing/generic.ml @@ -160,6 +160,7 @@ let static_method_container gctx c cf p = m_id = alloc_mid(); m_path = (pack,name); m_types = []; + m_statics = None; m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake m.m_extra.m_check_policy; } in gctx.mg <- Some mg; @@ -205,6 +206,7 @@ let rec build_generic ctx c p tl = m_id = alloc_mid(); m_path = (pack,name); m_types = []; + m_statics = None; m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake m.m_extra.m_check_policy; } in gctx.mg <- Some mg; diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index e236adf4d12..2eb7f823b7d 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -598,7 +598,7 @@ let is_public (ctx,cctx) access parent = true else match parent with | Some cf -> (has_class_field_flag cf CfPublic) - | _ -> c.cl_extern || c.cl_interface || cctx.extends_public + | _ -> c.cl_extern || c.cl_interface || cctx.extends_public || (match c.cl_kind with KModuleStatics _ -> true | _ -> false) let rec get_parent c name = match c.cl_super with diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index 28472a45dc4..395b00158ed 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -39,6 +39,7 @@ let make_module ctx mpath file loadp = m_id = alloc_mid(); m_path = mpath; m_types = []; + m_statics = None; m_extra = module_extra (Path.unique_full_path file) (Define.get_signature ctx.com.defines) (file_time file) (if ctx.in_macro then MMacro else MCode) (get_policy ctx mpath); } in m @@ -194,6 +195,7 @@ let module_pass_1 ctx m tdecls loadp = if priv then (fst m.m_path @ ["_" ^ snd m.m_path], name) else (fst m.m_path, name) in let pt = ref None in + let globals = ref [] in let rec make_decl acc decl = let p = snd decl in let check_type_name type_name meta = @@ -205,6 +207,9 @@ let module_pass_1 ctx m tdecls loadp = (match !pt with | None -> acc | Some _ -> error "import and using may not appear after a type declaration" p) + | EGlobal d -> + globals := (d,p) :: !globals; + acc; | EClass d -> let name = fst d.d_name in pt := Some p; @@ -341,6 +346,43 @@ let module_pass_1 ctx m tdecls loadp = decl :: acc in let tdecls = List.fold_left make_decl [] tdecls in + let tdecls = + match !globals with + | [] -> + tdecls + | globals -> + let first_pos = ref null_pos in + let fields = List.map (fun (d,p) -> + first_pos := p; + { + cff_name = d.d_name; + cff_doc = d.d_doc; + cff_pos = p; + cff_meta = d.d_meta; + cff_access = (AStatic,null_pos) :: d.d_flags; + cff_kind = d.d_data; + } + ) globals in + let p = !first_pos in + let c = EClass { + d_name = (snd m.m_path) ^ "_Statics_", p; + d_flags = [HPrivate]; + d_data = fields; + d_doc = None; + d_params = []; + d_meta = [] + } in + let tdecls = make_decl tdecls (c,p) in + (match !decls with + | (TClassDecl c,_) :: _ -> + assert (m.m_statics = None); + m.m_statics <- Some c; + c.cl_kind <- KModuleStatics m; + c.cl_final <- true; + | _ -> assert false); + tdecls + + in let decls = List.rev !decls in decls, List.rev tdecls @@ -483,7 +525,16 @@ let init_module_type ctx context_init (decl,p) = | [] -> (match name with | None -> - ctx.m.module_types <- List.filter no_private (List.map (fun t -> t,p) types) @ ctx.m.module_types + ctx.m.module_types <- List.filter no_private (List.map (fun t -> t,p) types) @ ctx.m.module_types; + Option.may (fun c -> + context_init#add (fun () -> + ignore(c.cl_build()); + List.iter (fun cf -> + if has_class_field_flag cf CfPublic then + ctx.m.module_globals <- PMap.add cf.cf_name (TClassDecl c,cf.cf_name,p) ctx.m.module_globals + ) c.cl_ordered_statics + ); + ) md.m_statics | Some(newname,pname) -> ctx.m.module_types <- (rebind (get_type tname) newname pname,p) :: ctx.m.module_types); | [tsub,p2] -> @@ -804,6 +855,9 @@ let init_module_type ctx context_init (decl,p) = else error "Abstract is missing underlying type declaration" a.a_pos end + | EGlobal _ -> + (* nothing to do here as globals are collected into a special EClass *) + () let module_pass_2 ctx m decls tdecls p = (* here is an additional PASS 1 phase, which define the type parameters for all module types. diff --git a/src/typing/typer.ml b/src/typing/typer.ml index 5e188c1c491..ee2073b2e79 100644 --- a/src/typing/typer.ml +++ b/src/typing/typer.ml @@ -370,6 +370,15 @@ let rec type_ident_raise ctx i p mode = let e = type_type ctx ctx.curclass.cl_path p in (* check_locals_masking already done in type_type *) field_access ctx mode f (FStatic (ctx.curclass,f)) (field_type ctx ctx.curclass [] f p) e p + with Not_found -> try + (* module-level statics *) + (match ctx.m.curmod.m_statics with + | None -> raise Not_found + | Some c -> + let f = PMap.find i c.cl_statics in + let e = type_module_type ctx (TClassDecl c) None p in + field_access ctx mode f (FStatic (c,f)) (field_type ctx c [] f p) e p + ) with Not_found -> try let wrap e = if mode = MSet then AKNo i