diff --git a/doc/CHANGES.txt b/doc/CHANGES.txt index 96f33c3e119..8da6b6c5894 100644 --- a/doc/CHANGES.txt +++ b/doc/CHANGES.txt @@ -28,6 +28,8 @@ TODO : all : renamed haxe.Http.request to "requestUrl" all : renamed neko.zip.Compress/Uncompress.run to "execute" spod : fix very rare issue with relations and transactions + compiler : added TClosure - optimize closure creation and ease code generation + cpp : added CPP platform 2009-03-22: 2.03 optimized Type.enumEq : use index instead of tag comparison for neko/flash9/php diff --git a/genas3.ml b/genas3.ml index 632cb6cd864..30588ac122b 100644 --- a/genas3.ml +++ b/genas3.ml @@ -471,7 +471,7 @@ and gen_expr ctx e = gen_value_op ctx e2; | TField ({ eexpr = TTypeExpr t },s) when t_path t = ctx.curclass.cl_path && not (PMap.mem s ctx.locals) -> print ctx "%s" (s_ident s) - | TField (e,s) -> + | TField (e,s) | TClosure (e,s) -> gen_value ctx e; gen_field_access ctx e.etype s | TTypeExpr t -> @@ -736,6 +736,7 @@ and gen_value ctx e = | TArray _ | TBinop _ | TField _ + | TClosure _ | TTypeExpr _ | TParenthesis _ | TObjectDecl _ diff --git a/gencpp.ml b/gencpp.ml index 380bff1bb2f..fd26ac21c80 100644 --- a/gencpp.ml +++ b/gencpp.ml @@ -511,6 +511,7 @@ let debug_expression expression type_too = | TArray (_,_) -> "TArray" | TBinop (_,_,_) -> "TBinop" | TField (_,_) -> "TField" + | TClosure _ -> "TClosure" | TTypeExpr _ -> "TTypeExpr" | TParenthesis _ -> "TParenthesis" | TObjectDecl _ -> "TObjectDecl" @@ -558,6 +559,7 @@ let rec iter_retval f retval e = f false e2; | TThrow e | TField (e,_) + | TClosure (e,_) | TUnop (_,_,e) -> f true e | TParenthesis e -> @@ -1145,6 +1147,7 @@ let rec gen_expression ctx retval expression = end (* Get precidence matching haxe ? *) | TBinop (op,expr1,expr2) -> gen_bin_op op expr1 expr2 + | TClosure (expr,name) | TField (expr,name) -> gen_member_access expr name (is_function_member expression) expression.etype | TParenthesis expr -> output "("; gen_expression ctx true expr; output ")" diff --git a/genjs.ml b/genjs.ml index c0776c395b8..02fea32c9fa 100644 --- a/genjs.ml +++ b/genjs.ml @@ -229,16 +229,14 @@ and gen_expr ctx e = print ctx " %s " (Ast.s_binop op); gen_value_op ctx e2; | TField (x,s) -> - (match follow e.etype with - | TFun _ -> - spr ctx "$closure("; - gen_value ctx x; - spr ctx ","; - gen_constant ctx e.epos (TString s); - spr ctx ")"; - | _ -> - gen_value ctx x; - spr ctx (field s)) + gen_value ctx x; + spr ctx (field s) + | TClosure (x,s) -> + spr ctx "$closure("; + gen_value ctx x; + spr ctx ","; + gen_constant ctx e.epos (TString s); + spr ctx ")"; | TTypeExpr t -> spr ctx (s_path (t_path t)) | TParenthesis e -> @@ -512,6 +510,7 @@ and gen_value ctx e = | TArray _ | TBinop _ | TField _ + | TClosure _ | TTypeExpr _ | TParenthesis _ | TObjectDecl _ diff --git a/genneko.ml b/genneko.ml index e288f4a2b5b..3b1e50f9d9b 100644 --- a/genneko.ml +++ b/genneko.ml @@ -233,19 +233,6 @@ and gen_call ctx p e el = let e = (match gen_expr ctx e with EFunction _, _ as e -> (EBlock [e],p) | e -> e) in call p e (List.map (gen_expr ctx) el) -and gen_closure p ep t e f = - match follow t with - | TFun (args,_) -> - let n = List.length args in - if n > 5 then error "Cannot create closure with more than 5 arguments" ep; - let tmp = ident p "@tmp" in - EBlock [ - (EVars ["@tmp", Some e; "@fun", Some (field p tmp f)] , p); - call p (ident p ("@closure" ^ string_of_int n)) [tmp;ident p "@fun"] - ] , p - | _ -> - field p e f - and gen_expr ctx e = let p = pos ctx e.epos in match e.eexpr with @@ -265,8 +252,19 @@ and gen_expr ctx e = (EBinop ("=",field p (gen_expr ctx e1) f,gen_expr ctx e2),p) | TBinop (op,e1,e2) -> gen_binop ctx p op e1 e2 - | TField (e2,f) -> - gen_closure p e.epos e.etype (gen_expr ctx e2) f + | TField (e,f) -> + field p (gen_expr ctx e) f + | TClosure (e2,f) -> + (match follow e.etype with + | TFun (args,_) -> + let n = List.length args in + if n > 5 then error "Cannot create closure with more than 5 arguments" e.epos; + let tmp = ident p "@tmp" in + EBlock [ + (EVars ["@tmp", Some (gen_expr ctx e2); "@fun", Some (field p tmp f)] , p); + call p (ident p ("@closure" ^ string_of_int n)) [tmp;ident p "@fun"] + ] , p + | _ -> assert false) | TTypeExpr t -> gen_type_path p (t_path t) | TParenthesis e -> diff --git a/genphp.ml b/genphp.ml index e5fa34968ec..f7ae81d98b6 100644 --- a/genphp.ml +++ b/genphp.ml @@ -76,6 +76,7 @@ let s_expr_expr e = | TArray (_,_) -> "TArray" | TBinop (_,_,_) -> "TBinop" | TField (_,_) -> "TField" + | TClosure (_,_) -> "TClosure" | TTypeExpr _ -> "TTypeExpr" | TParenthesis _ -> "TParenthesis" | TObjectDecl _ -> "TObjectDecl" @@ -1034,7 +1035,7 @@ and gen_expr ctx e = print ctx " %s " (Ast.s_binop op); gen_value_op ctx e2; ); - | TField (e1,s) -> + | TField (e1,s) | TClosure (e1,s) -> (match follow e.etype with | TFun (args, _) -> let p = escphp ctx.quotes in @@ -1453,6 +1454,7 @@ and gen_value ctx e = | TArray _ | TBinop _ | TField _ + | TClosure _ | TParenthesis _ | TObjectDecl _ | TArrayDecl _ diff --git a/genswf8.ml b/genswf8.ml index eaf4217d89f..5c8a070f5aa 100644 --- a/genswf8.ml +++ b/genswf8.ml @@ -589,13 +589,15 @@ let rec gen_access ?(read_write=false) ctx forcall e = write ctx ASwap; push ctx [p]; end; - (match follow e.etype with - | TFun _ -> VarClosure - | _ -> - if not !protect_all && Codegen.is_volatile e.etype then - VarVolatile - else - VarObj) + if not !protect_all && Codegen.is_volatile e.etype then + VarVolatile + else + VarObj + | TClosure (e,f) -> + gen_expr ctx true e; + if read_write then assert false; + push ctx [VStr (f,is_protected ctx e.etype f)]; + VarClosure | TArray (ea,eb) -> if read_write then try @@ -958,6 +960,7 @@ and gen_expr_2 ctx retval e = | TConst TSuper | TConst TThis | TField _ + | TClosure _ | TArray _ | TLocal _ | TTypeExpr _ diff --git a/genswf9.ml b/genswf9.ml index fabcfeb2657..58cd3b4ad80 100644 --- a/genswf9.ml +++ b/genswf9.ml @@ -733,7 +733,7 @@ let gen_access ctx e (forset : 'a) : 'a access = match e.eexpr with | TLocal i -> gen_local_access ctx i e.epos forset - | TField (e1,f) -> + | TField (e1,f) | TClosure (e1,f) -> let id, k, closure = property ctx f e1.etype in if closure && not ctx.for_call then error "In Flash9, this method cannot be accessed this way : please define a local function" e1.epos; (match e1.eexpr with @@ -897,6 +897,7 @@ let rec gen_expr_content ctx retval e = ctx.infos.icond <- true; no_value ctx retval | TField _ + | TClosure _ | TLocal _ | TTypeExpr _ -> getvar ctx (gen_access ctx e Read) @@ -1586,7 +1587,7 @@ let generate_construct ctx fdata c = (* --- *) PMap.iter (fun _ f -> match f.cf_expr with - | Some { eexpr = TFunction fdata } when f.cf_set = NormalAccess -> + | Some { eexpr = TFunction fdata } when f.cf_set = MethodDynamicAccess -> let id = ident f.cf_name in write ctx (HFindProp id); write ctx (HFunction (generate_method ctx fdata false)); @@ -1622,7 +1623,7 @@ let generate_class_init ctx c hc = write ctx (HClassDef hc); List.iter (fun f -> match f.cf_expr with - | Some { eexpr = TFunction fdata } when f.cf_set = NormalAccess -> + | Some { eexpr = TFunction fdata } when f.cf_set = MethodDynamicAccess -> write ctx HDup; write ctx (HFunction (generate_method ctx fdata true)); write ctx (HInitProp (ident f.cf_name)); @@ -1674,7 +1675,7 @@ let generate_field_kind ctx f c stat = | Some (c,_) -> PMap.exists f.cf_name c.cl_fields || loop c in - if f.cf_set = NormalAccess then + if f.cf_set = NormalAccess || f.cf_set = MethodDynamicAccess then Some (HFVar { hlv_type = Some (type_path ctx ([],"Function")); hlv_value = HVNone; diff --git a/genxml.ml b/genxml.ml index db9e05e3fc1..4f20313dd9d 100644 --- a/genxml.ml +++ b/genxml.ml @@ -85,7 +85,7 @@ let gen_constr e = let gen_field att f = let add_get_set acc name att = match acc with - | NormalAccess | ResolveAccess -> att + | NormalAccess | ResolveAccess | MethodDynamicAccess -> att | NoAccess | NeverAccess -> (name, "null") :: att | MethodAccess m -> (name, if m = name ^ "_" ^ f.cf_name then "dynamic" else m) :: att | MethodCantAccess -> att diff --git a/std/flash/Boot.hx b/std/flash/Boot.hx index 99e947b7be0..ebe50e11be4 100644 --- a/std/flash/Boot.hx +++ b/std/flash/Boot.hx @@ -265,8 +265,8 @@ class Boot { current.flash.Lib._root = _root; current.flash.Lib.current = current; // prevent closure creation by setting untyped - current[__unprotect__("@instanceof")] = untyped __instanceof; - current[__unprotect__("@closure")] = untyped __closure; + current[__unprotect__("@instanceof")] = flash.Boot[__unprotect__("__instanceof")]; + current[__unprotect__("@closure")] = flash.Boot[__unprotect__("__closure")]; // fix firefox default alignement if( _global["Stage"]["align"] == "" ) _global["Stage"]["align"] = "LT"; diff --git a/tests/unit/TestMisc.hx b/tests/unit/TestMisc.hx index 1f2bed1925e..de6ddff5120 100644 --- a/tests/unit/TestMisc.hx +++ b/tests/unit/TestMisc.hx @@ -1,5 +1,35 @@ package unit; +class MyDynamicClass { + + var v : Int; + + public function new(v) { + this.v = v; + } + + public function get() { + return v; + } + + public dynamic function add(x,y) { + return v + x + y; + } + + public inline function iadd(x,y) { + return v + x + y; + } + +} + +class MyDynamicSubClass extends MyDynamicClass { + + override function add(x,y) { + return (v + x + y) * 2; + } + +} + class TestMisc extends Test { function testClosure() { @@ -17,12 +47,47 @@ class TestMisc extends Test { var o = { f : f }; eq( o.f(), 5 ); + eq( o.f, o.f ); // we shouldn't create a new closure here var o = { add : c.add }; eq( o.add(1,2), 103 ); + eq( o.add, o.add ); // we shouldn't create a new closure here var o = { cos : Math.cos }; eq( o.cos(0), 1. ); + + // check enum + var c = MyEnum.C; + t( Type.enumEq(MyEnum.C(1,"hello"), c(1,"hello")) ); + } + + function testInlineClosure() { + var inst = new MyDynamicClass(100); + var add = inst.iadd; + eq( inst.iadd(1,2), 103 ); + eq( add(1,2), 103 ); + } + + function testDynamicClosure() { + var inst = new MyDynamicClass(100); + var add = inst.add; + eq( inst.add(1,2), 103 ); + eq( callback(inst.add,1)(2), 103 ); + eq( add(1,2), 103 ); + + // check overriden dynamic method + var inst = new MyDynamicSubClass(100); + var add = inst.add; + eq( inst.add(1,2), 206 ); + eq( callback(inst.add,1)(2), 206 ); + eq( add(1,2), 206 ); + + // check redefined dynamic method + inst.add = function(x,y) return inst.get() * 2 + x + y; + var add = inst.add; + eq( inst.add(1,2), 203 ); + eq( callback(inst.add,1)(2), 203 ); + eq( add(1,2), 203 ); } function testMD5() { diff --git a/tests/unit/TestType.hx b/tests/unit/TestType.hx index e4195d438f7..49262fb3ef8 100644 --- a/tests/unit/TestType.hx +++ b/tests/unit/TestType.hx @@ -3,19 +3,27 @@ import unit.MyEnum; class TestType extends Test { + static inline function u( s : String ) : String { + #if flash + return untyped __unprotect__(s); + #else + return s; + #end + } + public function testType() { - eq( Type.resolveClass("unit.MyClass"), unit.MyClass ); - eq( Type.getClassName(unit.MyClass), "unit.MyClass" ); + var name = u("unit")+"."+u("MyClass"); + eq( Type.resolveClass(name), unit.MyClass ); + eq( Type.getClassName(unit.MyClass), name ); eq( Type.getClassFields(unit.MyClass).length , 0 ); } - public function testFields() { var sfields = Type.getClassFields(unit.MySubClass); eq( sfields.length , 1 ); - eq( sfields[0], "XXX" ); + eq( sfields[0], u("XXX") ); - var fields = ["add","get","intValue","ref","set","stringValue","val"]; + var fields = [u("add"),u("get"),u("intValue"),u("ref"),u("set"),u("stringValue"),u("val")]; var fl = Type.getInstanceFields(unit.MyClass); fl.sort(Reflect.compare); eq( fl.join("|"), fields.join("|") ); diff --git a/type.ml b/type.ml index 4fe83531a23..274fdf6c854 100644 --- a/type.ml +++ b/type.ml @@ -26,6 +26,7 @@ type field_access = | ResolveAccess | MethodAccess of string | MethodCantAccess + | MethodDynamicAccess | NeverAccess | InlineAccess @@ -75,6 +76,7 @@ and texpr_expr = | TArray of texpr * texpr | TBinop of Ast.binop * texpr * texpr | TField of texpr * string + | TClosure of texpr * string | TTypeExpr of module_type | TParenthesis of texpr | TObjectDecl of (string * texpr) list @@ -290,9 +292,10 @@ let s_access = function | NoAccess -> "null" | NeverAccess -> "never" | MethodAccess m -> m - | MethodCantAccess -> "dynamic" + | MethodCantAccess -> "default" | ResolveAccess -> "resolve" | InlineAccess -> "inline" + | MethodDynamicAccess -> "dynamic" let rec is_parent csup c = if c == csup then @@ -791,6 +794,7 @@ let iter f e = f e2; | TThrow e | TField (e,_) + | TClosure (e,_) | TParenthesis e | TUnop (_,_,e) -> f e @@ -846,6 +850,8 @@ let map_expr f e = { e with eexpr = TThrow (f e1) } | TField (e1,v) -> { e with eexpr = TField (f e1,v) } + | TClosure (e1,v) -> + { e with eexpr = TClosure (f e1,v) } | TParenthesis e1 -> { e with eexpr = TParenthesis (f e1) } | TUnop (op,pre,e1) -> @@ -896,6 +902,8 @@ let map_expr_type f ft e = { e with eexpr = TThrow (f e1); etype = ft e.etype } | TField (e1,v) -> { e with eexpr = TField (f e1,v); etype = ft e.etype } + | TClosure (e1,v) -> + { e with eexpr = TClosure (f e1,v); etype = ft e.etype } | TParenthesis e1 -> { e with eexpr = TParenthesis (f e1); etype = ft e.etype } | TUnop (op,pre,e1) -> diff --git a/typeload.ml b/typeload.ml index ff77638e769..7abe08be2a5 100644 --- a/typeload.ml +++ b/typeload.ml @@ -616,7 +616,7 @@ let init_class ctx c p herits fields = let stat = List.mem AStatic access in let inline = List.mem AInline access in let parent = (if not stat then get_parent c name else None) in - let dynamic = List.mem ADynamic access || (match parent with Some { cf_set = NormalAccess } -> true | _ -> false) in + let dynamic = List.mem ADynamic access || (match parent with Some { cf_set = MethodDynamicAccess } -> true | _ -> false) in let ctx = { ctx with curclass = c; curmethod = name; @@ -641,7 +641,7 @@ let init_class ctx c p herits fields = cf_doc = doc; cf_type = t; cf_get = if inline then InlineAccess else NormalAccess; - cf_set = (if inline then NeverAccess else if dynamic then NormalAccess else MethodCantAccess); + cf_set = (if inline then NeverAccess else if dynamic then MethodDynamicAccess else MethodCantAccess); cf_expr = None; cf_public = is_public access parent; cf_params = params; diff --git a/typer.ml b/typer.ml index 0ee7aeff8ac..ae452172b13 100644 --- a/typer.ml +++ b/typer.ml @@ -28,6 +28,11 @@ type switch_mode = | CMatch of (tenum_field * (string option * t) list option) | CExpr of texpr +type access_mode = + | MGet + | MSet + | MCall + exception Display of t type access_kind = @@ -206,7 +211,7 @@ let type_type ctx tpath p = cf_public = true; cf_type = f.ef_type; cf_get = NormalAccess; - cf_set = NoAccess; + cf_set = (match follow f.ef_type with TFun _ -> MethodCantAccess | _ -> NoAccess); cf_doc = None; cf_expr = None; cf_params = []; @@ -263,13 +268,13 @@ let acc_get g p = ignore(follow f.cf_type); (* force computing *) match f.cf_expr with | None -> error "Recursive inline is not supported" p - | Some { eexpr = TFunction _ } -> mk (TField (e,f.cf_name)) t p + | Some { eexpr = TFunction _ } -> mk (TClosure (e,f.cf_name)) t p | Some e -> let rec loop e = Type.map_expr loop { e with epos = p } in loop e -let field_access ctx get f t e p = - match if get then f.cf_get else f.cf_set with +let field_access ctx mode f t e p = + match (match mode with MGet | MCall -> f.cf_get | MSet -> f.cf_set) with | NoAccess -> let normal = AccExpr (mk (TField (e,f.cf_name)) t p) in (match follow e.etype with @@ -282,16 +287,18 @@ let field_access ctx get f t e p = if ctx.untyped then normal else AccNo f.cf_name) | MethodCantAccess when not ctx.untyped -> error "Cannot rebind this method : please use 'dynamic' before method declaration" p - | NormalAccess | MethodCantAccess -> - AccExpr (mk (TField (e,f.cf_name)) t p) + | NormalAccess | MethodCantAccess | MethodDynamicAccess -> + (match mode, f.cf_set with + | MGet, MethodCantAccess | MGet, MethodDynamicAccess -> AccExpr (mk (TClosure (e,f.cf_name)) t p) + | _ -> AccExpr (mk (TField (e,f.cf_name)) t p)) | MethodAccess m -> if m = ctx.curmethod && (match e.eexpr with TConst TThis -> true | TTypeExpr (TClassDecl c) when c == ctx.curclass -> true | _ -> false) then let prefix = if Common.defined ctx.com "as3" then "$" else "" in AccExpr (mk (TField (e,prefix ^ f.cf_name)) t p) - else if get then - AccExpr (mk (TCall (mk (TField (e,m)) (tfun [] t) p,[])) t p) - else + else if mode = MSet then AccSet (e,m,t,f.cf_name) + else + AccExpr (mk (TCall (mk (TField (e,m)) (tfun [] t) p,[])) t p) | ResolveAccess -> let fstring = mk (TConst (TString f.cf_name)) ctx.api.tstring p in let tresolve = tfun [ctx.api.tstring] t in @@ -301,47 +308,45 @@ let field_access ctx get f t e p = | InlineAccess -> AccInline (e,f,t) -let type_ident ctx i is_type p get = +let type_ident ctx i is_type p mode = match i with | "true" -> - if get then + if mode = MGet then AccExpr (mk (TConst (TBool true)) ctx.api.tbool p) else AccNo i | "false" -> - if get then + if mode = MGet then AccExpr (mk (TConst (TBool false)) ctx.api.tbool p) else AccNo i | "this" -> if not ctx.untyped && ctx.in_static then error "Cannot access this from a static function" p; - if get then + if mode = MGet then AccExpr (mk (TConst TThis) ctx.tthis p) else AccNo i | "super" -> - if not ctx.super_call then - AccNo i - else let t = (match ctx.curclass.cl_super with - | None -> error "Current class does not have a superclass" p - | Some (c,params) -> TInst(c,params) + | None -> error "Current class does not have a superclass" p + | Some (c,params) -> TInst(c,params) ) in if ctx.in_static then error "Cannot access super from a static function" p; - ctx.super_call <- false; - if get then - AccExpr (mk (TConst TSuper) t p) - else + if mode = MSet || not ctx.super_call then AccNo i + else begin + ctx.super_call <- false; + AccExpr (mk (TConst TSuper) t p) + end | "null" -> - if get then + if mode = MGet then AccExpr (null (mk_mono()) p) else AccNo i | "here" -> let infos = mk_infos ctx p [] in let e = type_expr ctx infos true in - if get then + if mode = MGet then AccExpr { e with etype = Typeload.load_normal_type ctx { tpackage = ["haxe"]; tname = "PosInfos"; tparams = [] } p false } else AccNo i @@ -353,12 +358,12 @@ let type_ident ctx i is_type p get = (* member variable lookup *) if ctx.in_static then raise Not_found; let t , f = class_field ctx.curclass i in - field_access ctx get f t (mk (TConst TThis) ctx.tthis p) p + field_access ctx mode f t (mk (TConst TThis) ctx.tthis p) p with Not_found -> try (* static variable lookup *) let f = PMap.find i ctx.curclass.cl_statics in let e = type_type ctx ctx.curclass.cl_path p in - field_access ctx get f (field_type f) e p + field_access ctx mode f (field_type f) e p with Not_found -> try (* lookup imported *) let rec loop l = @@ -377,10 +382,10 @@ let type_ident ctx i is_type p get = in let e = loop ctx.local_types in check_locals_masking ctx e; - if get then - AccExpr e - else + if mode = MSet then AccNo i + else + AccExpr e with Not_found -> try (* lookup type *) if not is_type then raise Not_found; @@ -437,7 +442,7 @@ let type_matching ctx (enum,params) (e,p) ecases first_case = | _ -> invalid() -let type_field ctx e i p get = +let type_field ctx e i p mode = let no_field() = if not ctx.untyped then display_error ctx (s_type (print_context()) e.etype ^ " has no field " ^ i) p; AccExpr (mk (TField (e,i)) (mk_mono()) p) @@ -448,7 +453,7 @@ let type_field ctx e i p get = match c.cl_dynamic with | Some t -> let t = apply_params c.cl_types params t in - if get && PMap.mem "resolve" c.cl_fields then + if mode = MGet && PMap.mem "resolve" c.cl_fields then AccExpr (mk (TCall (mk (TField (e,"resolve")) (tfun [ctx.api.tstring] t) p,[Typeload.type_constant ctx (String i) p])) t p) else AccExpr (mk (TField (e,i)) t p) @@ -461,7 +466,7 @@ let type_field ctx e i p get = let t , f = class_field c i in if e.eexpr = TConst TSuper && f.cf_set = NormalAccess && Common.platform ctx.com Flash9 then error "Cannot access superclass variable for calling : needs to be a proper method" p; if not f.cf_public && not (is_parent c ctx.curclass) && not ctx.untyped then display_error ctx ("Cannot access to private field " ^ i) p; - field_access ctx get f (apply_params c.cl_types params t) e p + field_access ctx mode f (apply_params c.cl_types params t) e p with Not_found -> try loop_dyn c params with Not_found -> @@ -478,7 +483,7 @@ let type_field ctx e i p get = | Statics c when is_parent c ctx.curclass -> () | _ -> display_error ctx ("Cannot access to private field " ^ i) p end; - field_access ctx get f (field_type f) e p + field_access ctx mode f (field_type f) e p with Not_found -> if is_closed a then no_field() @@ -489,12 +494,12 @@ let type_field ctx e i p get = cf_doc = None; cf_public = true; cf_get = NormalAccess; - cf_set = if get then NoAccess else NormalAccess; + cf_set = (match mode with MSet -> NormalAccess | MGet | MCall -> NoAccess); cf_expr = None; cf_params = []; } in a.a_fields <- PMap.add i f a.a_fields; - field_access ctx get f (field_type f) e p + field_access ctx mode f (field_type f) e p ) | TMono r -> if ctx.untyped && Common.defined ctx.com "swf-mark" && Common.defined ctx.com "flash" then ctx.com.warning "Mark" p; @@ -504,7 +509,7 @@ let type_field ctx e i p get = cf_doc = None; cf_public = true; cf_get = NormalAccess; - cf_set = if get then NoAccess else NormalAccess; + cf_set = (match mode with MSet -> NormalAccess | MGet | MCall -> NoAccess); cf_expr = None; cf_params = []; } in @@ -512,7 +517,7 @@ let type_field ctx e i p get = let t = TAnon { a_fields = PMap.add i f PMap.empty; a_status = x } in ctx.opened <- x :: ctx.opened; r := Some t; - field_access ctx get f (field_type f) e p + field_access ctx mode f (field_type f) e p | t -> no_field() @@ -563,7 +568,7 @@ let unify_int ctx e k = let rec type_binop ctx op e1 e2 p = match op with | OpAssign -> - let e1 = type_access ctx (fst e1) (snd e1) false in + let e1 = type_access ctx (fst e1) (snd e1) MSet in let e2 = type_expr_with_type ctx e2 (match e1 with AccNo _ | AccInline _ -> None | AccExpr e | AccSet(e,_,_,_) -> Some e.etype) in (match e1 with | AccNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p @@ -582,7 +587,7 @@ let rec type_binop ctx op e1 e2 p = | AccInline _ -> assert false) | OpAssignOp op -> - (match type_access ctx (fst e1) (snd e1) false with + (match type_access ctx (fst e1) (snd e1) MSet with | AccNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p | AccExpr e -> let eop = type_binop ctx op e1 e2 p in @@ -748,7 +753,7 @@ let rec type_binop ctx op e1 e2 p = and type_unop ctx op flag e p = let set = (op = Increment || op = Decrement) in - let acc = type_access ctx (fst e) (snd e) (not set) in + let acc = type_access ctx (fst e) (snd e) (if set then MSet else MGet) in let access e = let t = (match op with | Not -> @@ -818,7 +823,7 @@ and type_switch ctx e cases def need_val p = | (EConst (Ident name),p) :: l | (EConst (Type name),p) :: l -> (try - let e = acc_get (type_ident ctx name false p true) p in + let e = acc_get (type_ident ctx name false p MGet) p in (match e.eexpr with | TEnumField (e,_) -> Some (e, List.map (fun _ -> mk_mono()) e.e_types) | _ -> None) @@ -957,17 +962,17 @@ and type_switch ctx e cases def need_val p = let cases = List.map matchs cases in mk (TMatch (e,(en,enparams),List.map indexes cases,def)) t p -and type_access ctx e p get = +and type_access ctx e p mode = match e with | EConst (Ident s) -> - type_ident ctx s false p get + type_ident ctx s false p mode | EConst (Type s) -> - type_ident ctx s true p get + type_ident ctx s true p mode | EField _ | EType _ -> let fields path e = List.fold_left (fun e (f,_,p) -> - let e = acc_get (e true) p in + let e = acc_get (e MGet) p in type_field ctx e f p ) e path in @@ -1027,7 +1032,7 @@ and type_access ctx e p get = | _ -> fields acc (type_access ctx (fst e) (snd e)) in - loop [] (e,p) get + loop [] (e,p) mode | EArray (e1,e2) -> let e1 = type_expr ctx e1 in let e2 = type_expr ctx e2 in @@ -1061,7 +1066,7 @@ and type_expr ctx ?(need_val=true) (e,p) = | EArray _ | EConst (Ident _) | EConst (Type _) -> - acc_get (type_access ctx e p true) p + acc_get (type_access ctx e p MGet) p | EConst (Regexp (r,opt)) -> let str = mk (TConst (TString r)) ctx.api.tstring p in let opt = mk (TConst (TString opt)) ctx.api.tstring p in @@ -1169,7 +1174,7 @@ and type_expr ctx ?(need_val=true) (e,p) = unify_raise ctx e1.etype t e1.epos; e1 with Error (Unify _,_) -> - let acc = acc_get (type_field ctx e1 "iterator" e1.epos true) e1.epos in + let acc = acc_get (type_field ctx e1 "iterator" e1.epos MCall) e1.epos in match follow acc.etype with | TFun ([],it) -> unify ctx it t e1.epos; @@ -1483,8 +1488,8 @@ and type_call ctx e el p = | _ -> (match e with | EField ((EConst (Ident "super"),_),_) , _ | EType ((EConst (Ident "super"),_),_) , _ -> ctx.super_call <- true - | _ -> ()); - match type_access ctx (fst e) (snd e) true with + | _ -> ()); + match type_access ctx (fst e) (snd e) MCall with | AccInline (ethis,f,t) -> let params, tret = (match follow t with | TFun (args,r) -> unify_call_params ctx (Some f.cf_name) el args p true, r