added TClosure

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

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 _

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 ")"

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 _

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 ->

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 _

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 _

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;

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

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";

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() {

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("|") );