macros parameters check

added haxe.macro.Context
allowed macros-in-macro

interp.ml

@@ -64,6 +64,8 @@ type cmp =
 	| CInf
 	| CUndef
 
+type locals = (string, value ref) PMap.t
+
 type context = {
 	com : Common.context;
 	gen : Genneko.context;
@@ -75,10 +77,13 @@ type context = {
 	mutable do_string : value -> string;
 	mutable do_loadprim : value -> value -> value;
 	mutable do_compare : value -> value -> cmp;
-	mutable locals : (string, value ref) PMap.t;
-	mutable stack : pos list;
+	mutable locals : locals;
+	mutable stack : (pos * value * locals) list;
 	mutable exc : pos list;
 	mutable vthis : value;
+	(* context *)
+	mutable curpos : Ast.pos;
+	mutable delayed : (unit -> value) DynArray.t;
 }
 
 type access =
@@ -91,6 +96,7 @@ exception Builtin_error
 
 exception Error of string * Ast.pos list
 
+exception Abort
 exception Continue
 exception Break of value
 exception Return of value
@@ -485,11 +491,18 @@ let builtins =
 			build_stack (get_ctx()).exc
 	 	);
 	 	"callstack", Fun0 (fun() ->
-	 		build_stack (get_ctx()).stack
+	 		build_stack (List.map (fun (p,_,_) -> p) (get_ctx()).stack)
 	 	);
 	 	"version", Fun0 (fun() ->
 	 		VInt 0
 	 	);
+	(* extra *)
+		"delay_call",Fun1 (fun i ->
+			let ctx = get_ctx() in
+			match i with
+			| VInt i when i >= 0 && i < DynArray.length ctx.delayed -> (DynArray.get ctx.delayed i)()
+			| _ -> error()
+		);
 	] in
 	let vals = [
 		"tnull", VInt 0;
@@ -970,11 +983,30 @@ let std_lib =
 	List.iter (fun (n,f) -> Hashtbl.add h n f) funcs;
 	h
 
+(* ---------------------------------------------------------------------- *)
+(* MACRO LIBRARY *)
+
+let macro_lib =
+	let error() =
+		raise Builtin_error
+	in
+	let funcs = [
+		"curpos", Fun0 (fun() -> VAbstract (APos (get_ctx()).curpos));
+		"error", Fun2 (fun msg p ->
+			match msg, p with
+			| VString s, VAbstract (APos p) -> (get_ctx()).com.Common.error s p; raise Abort
+			| _ -> error()
+		);
+	] in
+	let h = Hashtbl.create 0 in
+	List.iter (fun (n,f) -> Hashtbl.add h n f) funcs;
+	h
+
 (* ---------------------------------------------------------------------- *)
 (* EVAL *)
 
 let throw ctx p msg =
-	ctx.stack <- p :: ctx.stack;
+	ctx.stack <- (p,ctx.vthis,ctx.locals) :: ctx.stack;
 	exc (VString msg)
 
 let local ctx var value =
@@ -1087,7 +1119,7 @@ let rec eval ctx (e,p) =
 			eval ctx e
 		with Runtime v ->
 			let rec loop n l =
-				if n = 0 then l else
+				if n = 0 then List.map (fun (p,_,_) -> p) l else
 				match l with
 				| [] -> []
 				| _ :: l -> loop (n - 1) l
@@ -1389,7 +1421,7 @@ and call ctx vthis vfun pl p =
 	let oldstack = ctx.stack in
 	ctx.locals <- PMap.empty;
 	ctx.vthis <- vthis;
-	ctx.stack <- p :: ctx.stack;
+	ctx.stack <- (p,oldthis,locals) :: ctx.stack;
 	let ret = (try
 		(match vfun with
 		| VClosure (vl,f) ->
@@ -1403,9 +1435,9 @@ and call ctx vthis vfun pl p =
 			| [a;b;c;d], Fun4 f -> f a b c d
 			| [a;b;c;d;e], Fun5 f -> f a b c d e
 			| _, FunVar f -> f pl
-			| _ -> exc (VString "Invalid call"))
+			| _ -> exc (VString (Printf.sprintf "Invalid call (%d args instead of %d)" (List.length pl) (nargs f))))
 		| _ ->
-			exc (VString "Invalid call"))
+			exc (VString ("Invalid call " ^ ctx.do_string vfun)))
 	with Return v -> v
 		| Sys_error msg -> exc (VString msg)
 		| End_of_file -> exc (VString "EOF")
@@ -1432,6 +1464,7 @@ let rec to_string ctx n v =
 	| VArray vl -> "[" ^ String.concat "," (Array.to_list (Array.map (to_string ctx n) vl)) ^ "]"
 	| VAbstract a ->
 		(match a with
+		| APos p -> "#pos(" ^ Lexer.get_error_pos (Printf.sprintf "%s:%d:") p ^ ")"
 		| AInt32 i -> Int32.to_string i
 		| _ -> "#abstract")
 	| VFunction f -> "#function:"  ^ string_of_int (nargs f)
@@ -1499,6 +1532,7 @@ let load_prim ctx f n =
 		(try
 			let f = (match lib with
 			| "std" -> Hashtbl.find std_lib fname
+			| "macro" -> Hashtbl.find macro_lib fname
 			| _ -> raise Not_found
 			) in
 			if nargs f <> n then raise Not_found;
@@ -1508,6 +1542,11 @@ let load_prim ctx f n =
 	| _ ->
 		exc (VString "Invalid call")
 
+let alloc_delayed ctx f =
+	let pos = DynArray.length ctx.delayed in
+	DynArray.add ctx.delayed f;
+	pos
+
 let create com =
 	let ctx = {
 		com = com;
@@ -1525,6 +1564,9 @@ let create com =
 		do_string = Obj.magic();
 		do_loadprim = Obj.magic();
 		do_compare = Obj.magic();
+		(* context *)
+		curpos = Ast.null_pos;
+		delayed = DynArray.create();
 	} in
 	ctx.do_call <- call ctx;
 	ctx.do_string <- to_string ctx 0;
@@ -1534,11 +1576,18 @@ let create com =
 	List.iter (fun e -> ignore(eval ctx e)) (Genneko.header());
 	ctx
 
-let catch_errors ctx f =
+let catch_errors ctx ?(final=(fun() -> ())) f =
 	try
-		f();
+		let v = f() in
+		final();
+		Some v
 	with Runtime v ->
-		raise (Error (to_string ctx 0 v,List.map make_pos ctx.stack))
+		final();
+		raise (Error (to_string ctx 0 v,List.map (fun (p,_,_) -> make_pos p) ctx.stack))
+	| Abort ->
+		final();
+		None
+
 
 let add_types ctx types =
 	let types = List.filter (fun t ->
@@ -1549,7 +1598,7 @@ let add_types ctx types =
 		end
 	) types in
 	let e = (EBlock (Genneko.build ctx.gen types), null_pos) in
-	catch_errors ctx (fun() -> ignore(eval ctx e))
+	ignore(catch_errors ctx (fun() -> ignore(eval ctx e)))
 
 let get_path ctx path p =
 	let rec loop = function
@@ -1560,8 +1609,10 @@ let get_path ctx path p =
 	eval ctx (loop (List.rev path))
 
 let call_path ctx path f vl p =	
+	let old = ctx.curpos in
+	ctx.curpos <- p;
 	let p = Genneko.pos ctx.gen p in
-	catch_errors ctx (fun() ->
+	catch_errors ctx ~final:(fun() -> ctx.curpos <- old) (fun() ->
 		match get_path ctx path p with
 		| VObject o ->
 			let f = get_field o f in
@@ -1569,6 +1620,14 @@ let call_path ctx path f vl p =
 		| _ -> assert false
 	)
 
+let unwind_stack ctx =
+	match ctx.stack with
+	| [] -> ()
+	| (p,vthis,locals) :: l ->
+		ctx.stack <- l;
+		ctx.vthis <- vthis;
+		ctx.locals <- locals
+
 (* ---------------------------------------------------------------------- *)
 (* EXPR ENCODING *)
 

std/haxe/macro/Context.hx

@@ -0,0 +1,55 @@
+/*
+ * Copyright (c) 2005-2010, The haXe Project Contributors
+ * All rights reserved.
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ *   - Redistributions of source code must retain the above copyright
+ *     notice, this list of conditions and the following disclaimer.
+ *   - Redistributions in binary form must reproduce the above copyright
+ *     notice, this list of conditions and the following disclaimer in the
+ *     documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE HAXE PROJECT CONTRIBUTORS "AS IS" AND ANY
+ * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ * DISCLAIMED. IN NO EVENT SHALL THE HAXE PROJECT CONTRIBUTORS BE LIABLE FOR
+ * ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+ * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+ * DAMAGE.
+ */
+package haxe.macro;
+import haxe.macro.Expr;
+
+/**
+	This is an API that can be used by macros implementations.
+**/
+class Context {
+
+	/**
+		Display a compilation error at the given position in code
+	**/
+	public static function error( msg : String, pos : Position ) {
+		load("error",2)(untyped msg.__s, pos);
+	}
+
+	/**
+		Return the position at the place the macro is called
+	**/
+	public static function currentPos() : Position {
+		return load("curpos", 0)();
+	}
+
+	static function load( f, nargs ) : Dynamic {
+		#if macro
+		return neko.Lib.load("macro", f, nargs);
+		#else
+		return Reflect.makeVarArgs(function(_) throw "Can't be called outside of macro");
+		#end
+	}
+
+}

typeload.ml

@@ -629,6 +629,11 @@ let init_class ctx c p herits fields meta =
 	set_heritance ctx c herits p;
 	let core_api = has_meta ":core_api" meta in
 	let is_macro = has_meta ":macro" meta in
+	let in_macro = Common.defined ctx.com "macro" in
+	let fields, herits = if is_macro && not in_macro then begin
+		c.cl_extern <- true;
+		List.filter (function (FFun (_,_,_,acc,_,_),_) -> List.mem AStatic acc | _ -> false) fields, []
+	end else fields, herits in
 	if core_api then delay ctx ((fun() -> init_core_api ctx c));
 	let tthis = TInst (c,List.map snd c.cl_types) in
 	let rec extends_public c =
@@ -725,8 +730,15 @@ let init_class ctx c p herits fields meta =
 			let stat = List.mem AStatic access in
 			let inline = List.mem AInline access in
 			if inline && c.cl_interface then error "You can't declare inline methods in interfaces" p;
-			let is_macro = (is_macro && not stat) || has_meta ":macro" meta in
+			let is_macro = (is_macro && stat) || has_meta ":macro" meta in
 			if is_macro && not stat then error "Only static methods can be macros" p;
+			let f = if not is_macro then f else begin
+				let texpr = CTPath { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None } in
+				{ f with 
+					f_args = List.map (fun (a,o,t,e) -> a,o,(match t with None -> Some texpr | _ -> t),e) f.f_args;
+					f_expr = if in_macro then f.f_expr else (EReturn (Some (EConst (Ident "null"),p)),p);
+				}
+			end 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_kind = Method MethDynamic } -> true | _ -> false) in
 			if inline && dynamic then error "You can't have both 'inline' and 'dynamic'" p;

typer.ml

@@ -1625,7 +1625,29 @@ and type_call ctx e el p =
 			make_call ctx et (eparam::params) tret p
 		| AKMacro (ethis,f) ->
 			(match ethis.eexpr with
-			| TTypeExpr (TClassDecl c) -> (!type_macro_rec) ctx c f.cf_name el p
+			| TTypeExpr (TClassDecl c) ->
+				let expr = Typeload.load_instance ctx { tpackage = ["haxe";"macro"]; tname = "Expr"; tparams = []; tsub = None}  p false in
+				let nargs = (match follow f.cf_type with
+				| TFun (args,ret) ->
+					unify ctx ret expr p;
+					(match args with
+					| [(_,_,t)] ->
+						(try
+							unify_raise ctx t expr p;
+							Some 1
+						with Error (Unify _,_) ->
+							unify ctx t (ctx.api.tarray expr) p;
+							None)
+					| _ ->
+						List.iter (fun (_,_,t) -> unify ctx t expr p) args;
+						Some (List.length args))
+				| _ ->
+					assert false
+				) in
+				(match nargs with
+				| Some n -> if List.length el <> n then error ("This macro requires " ^ string_of_int n ^ " arguments") p
+				| None -> ());
+				(!type_macro_rec) ctx c f.cf_name el (nargs = None) p
 			| _ -> assert false)
 		| acc ->
 			let e = acc_get ctx acc p in
@@ -1902,7 +1924,7 @@ let create com =
 (* ---------------------------------------------------------------------- *)
 (* MACROS *)
 
-let type_macro ctx c f el p =
+let type_macro ctx c f el array p =
 	let t = Common.timer "macro execution" in
 	let ctx2 = (match ctx.g.macros with
 		| Some (select,ctx) -> 
@@ -1932,12 +1954,41 @@ let type_macro ctx c f el p =
 	let mctx = Interp.get_ctx() in
 	let m = (try Hashtbl.find ctx.g.types_module c.cl_path with Not_found -> c.cl_path) in
 	ignore(Typeload.load_module ctx2 m p);
-	finalize ctx2;
-	let types = types ctx2 None [] in
-	Interp.add_types mctx types;
-	let params = Interp.enc_array (List.map Interp.encode_expr el) in
-	let v = Interp.call_path mctx ((fst c.cl_path) @ [snd c.cl_path]) f [params] p in
-	let e = (try Interp.decode_expr v with Interp.Invalid_expr -> error "The macro didn't return a valid expression" p) in
+	let call() =
+		let el = List.map Interp.encode_expr el in
+		match Interp.call_path mctx ((fst c.cl_path) @ [snd c.cl_path]) f (if array then [Interp.enc_array el] else el) p with
+		| None -> None
+		| Some v -> Some (try Interp.decode_expr v with Interp.Invalid_expr -> error "The macro didn't return a valid expression" p)
+	in
+	let e = (if Common.defined ctx.com "macro" then begin
+		(*
+			this is super-tricky : we can't evaluate a macro inside a macro because we might trigger some cycles.
+			So instead, we generate a haxe.macro.Context.delayedCalled(i) expression that will only evaluate the
+			macro if/when it is called.
+
+			The tricky part is that the whole delayed-evaluation process has to use the same contextual informations
+			as if it was evaluated now.
+		*)
+		let ctx = {
+			ctx with locals = ctx.locals;
+		} in
+		let pos = Interp.alloc_delayed mctx (fun() ->
+			(* remove $delay_call calls from the stack *)
+			Interp.unwind_stack mctx;
+			match call() with
+			| None -> raise Interp.Abort
+			| Some e -> Interp.eval mctx (Genneko.gen_expr mctx.Interp.gen (type_expr ctx e))
+		) in
+		let e = (EConst (Ident "__dollar__delay_call"),p) in
+		(EUntyped (ECall (e,[EConst (Int (string_of_int pos)),p]),p),p)
+	end else begin
+		finalize ctx2;
+		let types = types ctx2 None [] in
+		Interp.add_types mctx types;
+		match call() with
+		| None -> (EConst (Ident "null"),p)
+		| Some e -> e
+	end) in
 	t();
 	type_expr ctx e