Private getters/setters

Author: RblSb

src/codegen/codegen.ml

@@ -28,8 +28,8 @@ open Extlib_leftovers
 let rec has_properties c =
 	List.exists (fun f ->
 		match f.cf_kind with
-		| Var { v_read = AccCall } -> true
-		| Var { v_write = AccCall } -> true
+		| Var { v_read = AccCall | AccPrivateCall } -> true
+		| Var { v_write = AccCall | AccPrivateCall } -> true
 		| _ when Meta.has Meta.Accessor f.cf_meta -> true
 		| _ -> false
 	) c.cl_ordered_fields || (match c.cl_super with Some (c,_) -> has_properties c | _ -> false)
@@ -40,10 +40,10 @@ let get_properties fields =
 			(f.cf_name, f.cf_name) :: acc
 		else
 			let acc = (match f.cf_kind with
-			| Var { v_read = AccCall } -> ("get_" ^ f.cf_name , "get_" ^ f.cf_name) :: acc
+			| Var { v_read = AccCall | AccPrivateCall } -> ("get_" ^ f.cf_name , "get_" ^ f.cf_name) :: acc
 			| _ -> acc) in
 			match f.cf_kind with
-			| Var { v_write = AccCall } -> ("set_" ^ f.cf_name , "set_" ^ f.cf_name) :: acc
+			| Var { v_write = AccCall | AccPrivateCall } -> ("set_" ^ f.cf_name , "set_" ^ f.cf_name) :: acc
 			| _ -> acc
 	) [] fields
 

src/codegen/genxml.ml

@@ -135,7 +135,7 @@ and gen_field att f =
 		match acc with
 		| AccNormal | AccRequire _ | AccCtor -> att
 		| AccNo | AccNever -> (name, "null") :: att
-		| AccCall -> (name,"accessor") :: att
+		| AccCall | AccPrivateCall -> (name,"accessor") :: att
 		| AccInline -> (name,"inline") :: att
 	in
 	let att = (match f.cf_expr with None -> att | Some e -> ("line",string_of_int (Lexer.get_error_line e.epos)) :: att) in

src/compiler/hxb/hxbReader.ml

@@ -993,6 +993,7 @@ class hxb_reader
 					let s = self#read_string in
 					let so = self#read_option (fun () -> self#read_string) in
 					AccRequire(s,so)
+				| 7 -> AccPrivateCall
 				| i ->
 					error (Printf.sprintf "Bad accessor kind: %i" i)
 			in

src/compiler/hxb/hxbWriter.ml

@@ -1710,6 +1710,7 @@ module HxbWriter = struct
 					Chunk.write_u8 writer.chunk 6;
 					Chunk.write_string writer.chunk s;
 					Chunk.write_option writer.chunk so (Chunk.write_string writer.chunk)
+				| AccPrivateCall -> Chunk.write_u8 writer.chunk 7
 			in
 			f r;
 			f w

src/context/display/findReferences.ml

@@ -39,7 +39,7 @@ let rec collect_reference_positions com (name,pos,kind) =
 			| Var vk ->
 				let host = FieldAccess.get_host c cf in
 				let check r mode = match r with
-					| AccCall ->
+					| AccCall | AccPrivateCall ->
 						begin match FieldAccess.find_accessor_for_field host cf cf.cf_type mode with
 						| AccessorFound (cf_acc,new_host) ->
 							let c_host = FieldAccess.get_host_class_raise new_host in

src/context/typecore.ml

@@ -517,8 +517,12 @@ let needs_inline ctx c cf =
 	cf.cf_kind = Method MethInline && ctx.allow_inline && (ctx.com.doinline || is_forced_inline c cf)
 
 (** checks if we can access to a given class field using current context *)
-let can_access ctx c cf stat =
-	if (has_class_field_flag cf CfPublic) then
+let can_access ctx c cf ?(check_prop=false) ?(is_setter=false) stat =
+	let is_not_private_prop = not check_prop || match cf.cf_kind with
+		| Var { v_read = AccPrivateCall } when not is_setter -> false
+		| Var { v_write = AccPrivateCall } when is_setter -> false
+		| _ -> true in
+	if (is_not_private_prop && has_class_field_flag cf CfPublic) then
 		true
 	else if c == ctx.c.curclass then
 		true

src/core/json/genjson.ml

@@ -497,6 +497,7 @@ and generate_class_field' ctx cfs cf =
 				| AccNever -> "AccNever",None
 				| AccCtor -> "AccCtor",None
 				| AccCall -> "AccCall",None
+				| AccPrivateCall -> "AccPrivateCall",None
 				| AccInline -> "AccInline",None
 				| AccRequire(s,so) -> "AccRequire",Some (jobject ["require",jstring s;"message",jopt jstring so])
 			in
@@ -736,4 +737,4 @@ let generate timer_ctx types file =
 		let ch = open_out_bin file in
 		Json.write_json (output_string ch) json;
 		close_out ch;
-	) ()
+	) ()

src/core/tOther.ml

@@ -58,7 +58,7 @@ module TExprToExpr = struct
 								| AccNormal | AccCtor | AccInline | AccRequire _ -> "default"
 								| AccNo -> "null"
 								| AccNever -> "never"
-								| AccCall -> get_or_set
+								| AccCall | AccPrivateCall -> get_or_set
 							in
 							let read = (var_access_to_string v.v_read "get",null_pos) in
 							let write = (var_access_to_string v.v_write "set",null_pos) in

src/core/tPrinting.ml

@@ -164,6 +164,7 @@ let s_access is_read = function
 	| AccNo -> "null"
 	| AccNever -> "never"
 	| AccCall -> if is_read then "get" else "set"
+	| AccPrivateCall -> if is_read then "private get" else "private set"
 	| AccInline	-> "inline"
 	| AccRequire (n,_) -> "require " ^ n
 	| AccCtor -> "ctor"

src/core/tType.ml

@@ -16,6 +16,7 @@ and var_access =
 	| AccNever          (* can't be accessed, even in subclasses *)
 	| AccCtor           (* can only be accessed from the constructor *)
 	| AccCall           (* perform a method call when accessed *)
+	| AccPrivateCall    (* perform a method call when accessed, but private like AccNo *)
 	| AccInline         (* similar to Normal but inline when accessed *)
 	| AccRequire of string * string option (* set when @:require(cond) fails *)
 

src/core/tUnification.ml

@@ -511,11 +511,12 @@ let unify_access a1 a2 =
 	a1 = a2 || match a1, a2 with
 	| _, AccNo | _, AccNever -> true
 	| AccInline, AccNormal -> true
+	| AccCall, AccPrivateCall -> true
 	| _ -> false
 
 let direct_access = function
 	| AccNo | AccNever | AccNormal | AccInline | AccRequire _ | AccCtor -> true
-	| AccCall -> false
+	| AccCall | AccPrivateCall -> false
 
 let unify_kind ~(strict:bool) k1 k2 =
 	k1 = k2 || match k1, k2 with
@@ -908,8 +909,8 @@ let rec unify (uctx : unification_context) a b =
 							with Not_found ->
 								()
 						in
-						(match vk.v_read with AccCall -> check ("get_" ^ f1.cf_name) | _ -> ());
-						(match vk.v_write with AccCall -> check ("set_" ^ f1.cf_name) | _ -> ());
+						(match vk.v_read with AccCall | AccPrivateCall -> check ("get_" ^ f1.cf_name) | _ -> ());
+						(match vk.v_write with AccCall | AccPrivateCall -> check ("set_" ^ f1.cf_name) | _ -> ());
 					| _ -> ()
 				end;
 				(match f1.cf_kind with

src/generators/cpp/cppRetyper.ml

@@ -1505,7 +1505,7 @@ let get_id path ids =
   | None ->
     let new_id = make_id 0 in
     (new_id, ObjectIds.add path new_id ids)
-  
+
 let native_field_name_remap field =
   match get_meta_string field.cf_meta Meta.Native with
   | Some nativeImpl ->
@@ -1533,7 +1533,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params =
     tcv_type = field.cf_type;
     tcv_default = None;
 
-    tcv_has_getter = (match field.cf_kind with | Var { v_read = AccCall } -> true | _ -> false);
+    tcv_has_getter = (match field.cf_kind with | Var { v_read = AccCall | AccPrivateCall } -> true | _ -> false);
     tcv_is_stackonly = has_meta Meta.StackOnly field.cf_meta;
     tcv_is_reflective = reflective class_def field;
     tcv_is_gc_element = cpp_type_of field.cf_type |> is_gc_element ctx;
@@ -1567,14 +1567,14 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params =
             (* We can't implement abstract functions as pure virtual due to cppia needing to construct the class *)
             let map_arg (name, _, t) =
               ( (alloc_var VGenerated name t null_pos), (get_default_value name) ) in
-            let expr = 
+            let expr =
               match follow ret with
               | TAbstract ({ a_path = ([], "Void") }, _) ->
                 { eexpr = TReturn None; etype = ret; epos = null_pos }
               | _ ->
                 let zero_val = Some { eexpr = TConst (TInt Int32.zero); etype = ret; epos = null_pos } in
                 { eexpr = TReturn zero_val; etype = ret; epos = null_pos } in
-            
+
             {
               tf_args = args |> List.map map_arg;
               tf_type = ret;
@@ -1611,7 +1611,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params =
       | Var _, _ ->
         Some (create_variable field)
       (* Dynamic methods are implemented as a physical field holding a closure *)
-      | Method MethDynamic, Some { eexpr = TFunction func } -> 
+      | Method MethDynamic, Some { eexpr = TFunction func } ->
         Some (create_variable { field with cf_expr = None; cf_kind = Var ({ v_read = AccNormal; v_write = AccNormal }) })
       (* Below should cause abstracts which have functions with no implementation to be generated as a field *)
       (* See Int32.hx as an example *)
@@ -1631,7 +1631,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params =
       None in
 
   let id, ids = get_id class_def.cl_path ids in
-  
+
   let static_functions =
     class_def.cl_ordered_statics
     |> List.filter_map (filter_functions true) in
@@ -1650,7 +1650,7 @@ let rec tcpp_class_from_tclass ctx ids slots class_def class_params =
     |> List.filter (fun field -> field.cf_name <> "__meta__" && field.cf_name <> "__rtti")
     |> List.filter_map filter_properties in
 
-  let functions = 
+  let functions =
     class_def.cl_ordered_fields
     |> List.filter_map (filter_functions true) in
 
@@ -1822,4 +1822,4 @@ and tcpp_enum_from_tenum ctx ids enum_def =
   in
   let enum = { te_enum = enum_def; te_id = self_id; te_constructors = constructors } in
 
-  (ids, enum)
+  (ids, enum)

src/generators/cpp/gen/cppCppia.ml

@@ -1799,7 +1799,7 @@ let generate_script_class common_ctx script class_def =
           | AccNormal | AccCtor -> IaAccessNormal
           | AccNo -> IaAccessNot
           | AccNever -> IaAccessNot
-          | AccCall ->
+          | AccCall | AccPrivateCall ->
               if
                 Meta.has Meta.NativeProperty class_def.cl_meta
                 || Meta.has Meta.NativeProperty field.cf_meta

src/generators/cpp/gen/cppGenClassImplementation.ml

@@ -47,7 +47,7 @@ let gen_function ctx class_def class_name is_static func =
       (gen_cpp_function_body ctx class_def is_static func.tcf_field.cf_name func.tcf_func code tail_code);
 
     output "\n\n";
-    
+
     (* generate dynamic version too ... *)
     if (not func.tcf_is_virtual || not func.tcf_is_overriding) && func.tcf_is_reflective then
       let tcpp_args = List.map (fun (v, _) -> cpp_type_of v.v_type) func.tcf_func.tf_args in
@@ -85,7 +85,7 @@ let gen_function ctx class_def class_name is_static func =
             Printf.sprintf "(::cpp::Struct< %s >) a%i" (tcpp_to_string arg) idx
           | _ ->
             Printf.sprintf "a%i" idx in
-            
+
         tcpp_args
         |> ExtList.List.mapi cast_prefix
         |> String.concat ", "
@@ -120,7 +120,7 @@ let gen_dynamic_function ctx class_def class_name is_static is_for_static_var (f
   let ret = if is_void then "(void)" else "return " in
 
   ctx.ctx_real_this_ptr <- false;
-  Printf.sprintf "HX_BEGIN_DEFAULT_FUNC(%s, %s)\n" func_name class_name |> output; 
+  Printf.sprintf "HX_BEGIN_DEFAULT_FUNC(%s, %s)\n" func_name class_name |> output;
   Printf.sprintf "%s _hx_run(%s)" return_type_str (print_arg_list func.tcf_func.tf_args "__o_") |> output;
 
   gen_cpp_function_body ctx class_def is_static func_name func.tcf_func "" "" no_debug;
@@ -273,7 +273,7 @@ let generate_native_class base_ctx tcpp_class =
   output_cpp "\n";
 
   gen_dynamic_function_allocator ctx output_cpp tcpp_class;
-  
+
   generate_native_constructor ctx output_cpp class_def false;
   gen_boot_field ctx output_cpp tcpp_class;
 
@@ -394,13 +394,13 @@ let generate_managed_class base_ctx tcpp_class =
     let impl_name = cpp_class_name class_def in
 
     let fold_interface (glued, acc) interface =
-    
+
       let rec gen_interface_funcs interface =
 
         let fold_field (glued, acc) func =
           let cast      = cpp_tfun_signature false func.iff_args func.iff_return in
           let real_name = cpp_member_name_of func.iff_field in
-          
+
           (* C++ can't work out which function it needs to take the addrss of
               when the implementation is overloaded - currently the map-set functions.
               Change the castKey to force a glue function in this case (could double-cast the pointer, but it is ugly)
@@ -452,7 +452,7 @@ let generate_managed_class base_ctx tcpp_class =
       let call     = Printf.sprintf "static %s %s_%s = {\n%s\n};\n" (cpp_class_name interface.if_class) cname interface_name combined in
       (glued, call :: acc)
     in
-    
+
     let glued, calls =
       List.fold_left
         fold_interface
@@ -615,7 +615,7 @@ let generate_managed_class base_ctx tcpp_class =
     else
       acc
   in
-  
+
   let castable f =
     match cpp_type_of f.cf_type with
     | TCppInst (t, _) as inst when Meta.has Meta.StructAccess t.cl_meta ->
@@ -671,7 +671,7 @@ let generate_managed_class base_ctx tcpp_class =
           Printf.sprintf "%s = inValue.Cast< %s >(); return inValue;" var.tcv_name casted in
 
         match var.tcv_field.cf_kind with
-        | Var { v_write = AccCall } ->
+        | Var { v_write = AccCall | AccPrivateCall } ->
           let prop_call = checkPropCall var.tcv_field in
           let setter    = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
           let call      = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()) ); } else { %s }" prop_call setter casted default in
@@ -690,7 +690,7 @@ let generate_managed_class base_ctx tcpp_class =
         let casted  = castable var.tcv_field in
 
         match var.tcv_field.cf_kind with
-        | Var { v_write = AccCall } ->
+        | Var { v_write = AccCall | AccPrivateCall } ->
           let prop_call = checkPropCall var.tcv_field in
           let setter    = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
           let call      = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()) ); }" prop_call setter casted in
@@ -717,7 +717,7 @@ let generate_managed_class base_ctx tcpp_class =
         let casted = castable var.tcv_field in
 
         match var.tcv_field.cf_kind with
-        | Var { v_write = AccCall } ->
+        | Var { v_write = AccCall | AccPrivateCall } ->
           let prop_call = checkPropCall var.tcv_field in
           let setter    = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
           let call      = Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); } else { %s = ioValue.Cast< %s >(); } return true;" prop_call setter casted var.tcv_name casted in
@@ -734,7 +734,7 @@ let generate_managed_class base_ctx tcpp_class =
     let fold_property (var:tcpp_class_variable) acc =
       if var.tcv_is_reflective && not (is_abstract_impl class_def) then
         match var.tcv_field.cf_kind with
-        | Var { v_write = AccCall } ->
+        | Var { v_write = AccCall | AccPrivateCall } ->
           let prop_call = checkPropCall var.tcv_field in
           let setter    = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
           let casted    = castable var.tcv_field in
@@ -965,7 +965,7 @@ let generate_managed_class base_ctx tcpp_class =
           | _ -> [] in
         current_virtual_functions_rev cls initial
       in
-    
+
       flatten_tcpp_class_functions_rec tcpp_class |> List.rev
     in
 

src/generators/flashProps.ml

@@ -29,8 +29,8 @@ let find_property_for_accessor ~isget cl tl accessor_name =
 		match Type.class_field cl tl prop_name with
 		| Some (prop_cl, prop_tl), _, prop_cf ->
 			(match prop_cf.cf_kind with
-			| Var { v_read = AccCall; v_write = AccCall | AccNever } when isget && is_flash_property prop_cf -> Some (prop_cl, prop_tl, prop_cf)
-			| Var { v_read = AccCall | AccNever; v_write = AccCall } when not isget && is_flash_property prop_cf -> Some (prop_cl, prop_tl, prop_cf)
+			| Var { v_read = AccCall | AccPrivateCall; v_write = AccCall | AccPrivateCall | AccNever } when isget && is_flash_property prop_cf -> Some (prop_cl, prop_tl, prop_cf)
+			| Var { v_read = AccCall | AccPrivateCall | AccNever; v_write = AccCall | AccPrivateCall } when not isget && is_flash_property prop_cf -> Some (prop_cl, prop_tl, prop_cf)
 			| _ -> None)
 		| _ -> None
 	with Not_found ->
@@ -47,8 +47,8 @@ let find_static_property_for_accessor ~isget cl accessor_name =
 	try
 		let prop_cf = PMap.find prop_name cl.cl_statics in
 		(match prop_cf.cf_kind with
-		| Var { v_read = AccCall; v_write = AccCall | AccNever } when isget && is_flash_property prop_cf -> Some prop_cf
-		| Var { v_read = AccCall | AccNever; v_write = AccCall } when not isget && is_flash_property prop_cf -> Some prop_cf
+		| Var { v_read = AccCall | AccPrivateCall; v_write = AccCall | AccPrivateCall | AccNever } when isget && is_flash_property prop_cf -> Some prop_cf
+		| Var { v_read = AccCall | AccPrivateCall | AccNever; v_write = AccCall | AccPrivateCall } when not isget && is_flash_property prop_cf -> Some prop_cf
 		| _ -> None)
 	with Not_found ->
 		None

src/generators/genphp7.ml

@@ -3891,6 +3891,8 @@ class class_builder ctx (cls:tclass) =
 					| Var { v_read = read; v_write = write } ->
 						if read = AccCall then getters := field.cf_name :: !getters;
 						if write = AccCall then setters := field.cf_name :: !setters;
+						if read = AccPrivateCall then getters := field.cf_name :: !getters;
+						if write = AccPrivateCall then setters := field.cf_name :: !setters;
 					| _ -> ()
 			in
 			List.iter collect cls.cl_ordered_fields;

src/generators/genpy.ml

@@ -1718,7 +1718,7 @@ module Generator = struct
 			match cf.cf_kind with
 				| Var _ when not (is_physical_field cf) ->
 					()
-				| Var({v_read = AccCall}) ->
+				| Var({v_read = AccCall | AccPrivateCall}) ->
 					if Meta.has Meta.IsVar cf.cf_meta then
 						DynArray.add fields cf.cf_name
 					else
@@ -1922,7 +1922,7 @@ module Generator = struct
 			print ctx "    @staticmethod\n    def _hx_empty_init(_hx_o):";
 			let found_fields = ref false in
 			List.iter (fun cf -> match cf.cf_kind with
-					| Var ({v_read = AccCall}) ->
+					| Var ({v_read = AccCall | AccPrivateCall}) ->
 						()
 					| Var _ ->
 						found_fields := true;

src/macro/macroApi.ml

@@ -1126,6 +1126,7 @@ and encode_var_access a =
 		| AccInline	-> 5, []
 		| AccRequire (s,msg) -> 6, [encode_string s; null encode_string msg]
 		| AccCtor -> 7, []
+		| AccPrivateCall -> 8, []
 	) in
 	encode_enum IVarAccess tag pl
 
@@ -1452,6 +1453,7 @@ let decode_var_access v =
 	| 5, [] -> AccInline
 	| 6, [s1;s2] -> AccRequire(decode_string s1, opt decode_string s2)
 	| 7, [] -> AccCtor
+	| 8, [] -> AccPrivateCall
 	| _ -> raise Invalid_expr
 
 let decode_method_kind v =