Parcourir la source

allow inline vars in metadata
-1.35 is now TFloat "-1.35" and not Unop "-" TFloat "1.35"

Nicolas Cannasse il y a 15 ans
Parent
commit
21217ce599
8 fichiers modifiés avec 55 ajouts et 49 suppressions
  1. 7 7
      codegen.ml
  2. 1 1
      genswf.ml
  3. 1 1
      genswf9.ml
  4. 1 1
      optimizer.ml
  5. 4 2
      type.ml
  6. 1 1
      typecore.ml
  7. 33 30
      typeload.ml
  8. 7 6
      typer.ml

+ 7 - 7
codegen.ml

@@ -243,7 +243,7 @@ let extend_xml_proxy ctx c t file p =
 						cf_type = t;
 						cf_public = true;
 						cf_doc = None;
-						cf_meta = [];
+						cf_meta = no_meta;
 						cf_get = ResolveAccess;
 						cf_set = NoAccess;
 						cf_params = [];
@@ -267,13 +267,13 @@ let build_metadata com t =
 	let api = com.type_api in
 	let p, meta, fields, statics = (match t with
 		| TClassDecl c ->
-			let fields = List.map (fun f -> f.cf_name,f.cf_meta) (c.cl_ordered_fields @ (match c.cl_constructor with None -> [] | Some f -> [{ f with cf_name = "_" }])) in
-			let statics =  List.map (fun f -> f.cf_name,f.cf_meta) c.cl_ordered_statics in
-			(c.cl_pos, ["",c.cl_meta],fields,statics)
+			let fields = List.map (fun f -> f.cf_name,f.cf_meta()) (c.cl_ordered_fields @ (match c.cl_constructor with None -> [] | Some f -> [{ f with cf_name = "_" }])) in
+			let statics =  List.map (fun f -> f.cf_name,f.cf_meta()) c.cl_ordered_statics in
+			(c.cl_pos, ["",c.cl_meta()],fields,statics)
 		| TEnumDecl e ->
-			(e.e_pos, ["",e.e_meta],List.map (fun n -> n, (PMap.find n e.e_constrs).ef_meta) e.e_names, [])
+			(e.e_pos, ["",e.e_meta()],List.map (fun n -> n, (PMap.find n e.e_constrs).ef_meta()) e.e_names, [])
 		| TTypeDecl t ->
-			(t.t_pos, ["",t.t_meta],(match follow t.t_type with TAnon a -> PMap.fold (fun f acc -> (f.cf_name,f.cf_meta) :: acc) a.a_fields [] | _ -> []),[])
+			(t.t_pos, ["",t.t_meta()],(match follow t.t_type with TAnon a -> PMap.fold (fun f acc -> (f.cf_name,f.cf_meta()) :: acc) a.a_fields [] | _ -> []),[])
 	) in
 	let filter l = 
 		let l = List.map (fun (n,ml) -> n, List.filter (fun (m,_) -> m.[0] <> ':') ml) l in
@@ -360,7 +360,7 @@ let on_generate ctx t =
 				| [] -> assert false
 				| name :: path -> c.cl_path <- (List.rev path,name))
 			| _ -> ()
-		) c.cl_meta;
+		) (c.cl_meta());
 		if has_rtti c && not (PMap.mem "__rtti" c.cl_statics) then begin
 			let f = mk_field "__rtti" ctx.api.tstring in
 			let str = Genxml.gen_type_string ctx.com t in

+ 1 - 1
genswf.ml

@@ -825,7 +825,7 @@ let generate com swf_header =
 						if not extern && s_type_path (t_path t) = e.f9_classname then
 							match t with
 							| TClassDecl c ->
-								if List.mem (":bind",[]) c.cl_meta then
+								if has_meta ":bind" c.cl_meta then
 									toremove := (t_path t) :: !toremove
 								else
 									error ("Class already exists in '" ^ file ^ "', use @:bind to redefine it") (t_pos t)

+ 1 - 1
genswf9.ml

@@ -1804,7 +1804,7 @@ let generate_class ctx c =
 					try
 						let f = PMap.find f.cf_name c.cl_fields in
 						if List.mem f.cf_name c.cl_overrides then raise Not_found;
-						f.cf_meta
+						f.cf_meta()
 					with Not_found ->
 						find_meta c
 			in			

+ 1 - 1
optimizer.ml

@@ -436,7 +436,7 @@ let rec reduce_loop ctx is_sub e =
 	| TCall ({ eexpr = TFunction func } as ef,el) ->
 		(match follow ef.etype with
 		| TFun (_,rt) ->
-			let cf = { cf_name = ""; cf_params = []; cf_type = ef.etype; cf_public = true; cf_doc = None; cf_meta = []; cf_get = NormalAccess; cf_set = NoAccess; cf_expr = None } in
+			let cf = { cf_name = ""; cf_params = []; cf_type = ef.etype; cf_public = true; cf_doc = None; cf_meta = no_meta; cf_get = NormalAccess; cf_set = NoAccess; cf_expr = None } in
 			let inl = (try type_inline ctx cf func (mk (TConst TNull) (mk_mono()) e.epos) el rt e.epos with Error (Custom _,_) -> None) in
 			(match inl with
 			| None -> e

+ 4 - 2
type.ml

@@ -124,7 +124,7 @@ and tclass_kind =
 	| KGeneric
 	| KGenericInstance of tclass * tparams
 
-and metadata = (string * texpr list) list
+and metadata = unit -> (string * texpr list) list
 
 and tclass = {
 	mutable cl_path : path;
@@ -212,7 +212,7 @@ let mk_class path pos =
 		cl_path = path;
 		cl_pos = pos;
 		cl_doc = None;
-		cl_meta = [];
+		cl_meta = (fun() -> []);
 		cl_private = false;
 		cl_kind = KNormal;
 		cl_extern = false;
@@ -506,6 +506,8 @@ let invalid_visibility n = Invalid_visibility n
 let has_no_field t n = Has_no_field (t,n)
 let has_extra_field t n = Has_extra_field (t,n)
 let error l = raise (Unify_error l)
+let has_meta m ml = List.mem (m,[]) (ml())
+let no_meta() = []
 
 type simple_access =
 	| SAYes

+ 1 - 1
typecore.ml

@@ -203,7 +203,7 @@ let mk_field name t = {
 	cf_name = name;
 	cf_type = t;
 	cf_doc = None;
-	cf_meta = [];
+	cf_meta = no_meta;
 	cf_public = true;
 	cf_get = NormalAccess;
 	cf_set = NormalAccess;

+ 33 - 30
typeload.ml

@@ -220,7 +220,7 @@ and load_complex_type ctx p t =
 				cf_params = [];
 				cf_expr = None;
 				cf_doc = None;
-				cf_meta = [];
+				cf_meta = no_meta;
 			} acc
 		in
 		mk_anon (List.fold_left loop PMap.empty l)
@@ -424,7 +424,7 @@ let set_heritance ctx c herits p =
 				if is_parent c cl then error "Recursive class" p;
 				if c.cl_interface then error "Cannot extend an interface" p;
 				if cl.cl_interface then error "Cannot extend by using an interface" p;
-				if List.mem (":final",[]) cl.cl_meta && not (List.mem (":hack",[]) c.cl_meta) then error "Cannot extend a final class" p;
+				if has_meta ":final" cl.cl_meta && not (has_meta ":hack" c.cl_meta) then error "Cannot extend a final class" p;
 				c.cl_super <- Some (cl,params)
 			| _ -> error "Should extend by using a class" p)
 		| HImplements t ->
@@ -534,35 +534,38 @@ let type_function ctx args ret static constr f p =
 	e , fargs
 
 let type_meta ctx meta =
-	let notconst p = error "Metadata should be constant" p in
-	let rec mk_const (e,p) =
-		match e with
-		| EConst c ->
-			(match c with
-			| Int _ | Float _ | String _ | Ident "true" | Ident "false" | Ident "null" -> type_constant ctx c p
-			| _ -> notconst p)
-		| EUnop (Neg,Prefix,(EConst c,_)) ->
+	let mcache = ref None in
+	let notconst e = error "Metadata should be constant" e.epos in
+	let rec chk_const e =
+		match e.eexpr with
+		| TConst c ->
 			(match c with
-			| Int i -> type_constant ctx (Int ("-" ^ i)) p
-			| Float f -> type_constant ctx (Float ("-" ^ f)) p
-			| _ -> notconst p)
-		| EObjectDecl fl ->
-			let rec loop (l,acc) (f,e) =
-				if PMap.mem f acc then error ("Duplicate field in object declaration : " ^ f) p;
-				let e = mk_const e in
-				let cf = mk_field f e.etype in
-				((f,e) :: l, PMap.add f cf acc)
-			in
-			let fields , types = List.fold_left loop ([],PMap.empty) fl in
-			mk (TObjectDecl (List.rev fields)) (TAnon { a_fields = types; a_status = ref Closed }) p
-		| EArrayDecl el ->
-			mk (TArrayDecl (List.map mk_const el)) (ctx.api.tarray t_dynamic) p
-		| EBlock [] ->
-			mk (TObjectDecl []) (TAnon { a_fields = PMap.empty; a_status = ref Closed}) p
+			| TInt _ | TFloat _ | TString _ | TBool _ | TNull -> ()
+			| _ -> notconst e)
+		| TParenthesis e ->
+			chk_const e
+		| TObjectDecl el ->
+			List.iter (fun (_,e) -> chk_const e) el
+		| TArrayDecl el ->
+			List.iter chk_const el
 		| _ ->
-			notconst p
-	in	
-	List.map (fun (s,el) -> s, List.map mk_const el) meta
+			notconst e
+	in
+	let mk_meta (m,el) =
+		let el = List.map (fun e -> type_expr ctx e true) el in
+		List.iter chk_const el;
+		m, el
+	in
+	let get_meta() =
+		match !mcache with
+		| None ->
+			let ml = List.map mk_meta meta in
+			mcache := Some ml;
+			ml
+		| Some ml -> ml
+	in
+	ctx.delays := [[fun() -> ignore(get_meta())]] @ !(ctx.delays);
+	get_meta
 
 let init_core_api ctx c =
 	let ctx2 = (match !(ctx.core_api) with
@@ -610,7 +613,7 @@ let init_class ctx c p herits fields =
 	c.cl_extern <- List.mem HExtern herits;
 	c.cl_interface <- List.mem HInterface herits;
 	set_heritance ctx c herits p;
-	let core_api = List.mem (":core_api",[]) c.cl_meta in
+	let core_api = has_meta ":core_api" c.cl_meta in
 	if core_api then ctx.delays := [(fun() -> init_core_api ctx c)] :: !(ctx.delays);	
 	let tthis = TInst (c,List.map snd c.cl_types) in
 	let rec extends_public c =

+ 7 - 6
typer.ml

@@ -204,7 +204,7 @@ let rec type_module_type ctx t tparams p =
 			};
 			t_private = true;
 			t_types = [];
-			t_meta = [];
+			t_meta = no_meta;
 		} in
 		let e = mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p in
 		check_locals_masking ctx e;
@@ -219,7 +219,7 @@ let rec type_module_type ctx t tparams p =
 				cf_get = NormalAccess;
 				cf_set = (match follow f.ef_type with TFun _ -> MethodAccess false | _ -> NoAccess);
 				cf_doc = None;
-				cf_meta = [];
+				cf_meta = no_meta;
 				cf_expr = None;
 				cf_params = [];
 			} acc
@@ -234,7 +234,7 @@ let rec type_module_type ctx t tparams p =
 			};
 			t_private = true;
 			t_types = e.e_types;
-			t_meta = [];
+			t_meta = no_meta;
 		} in
 		let e = mk (TTypeExpr (TEnumDecl e)) (TType (t_tmp,types)) p in
 		check_locals_masking ctx e;
@@ -578,7 +578,7 @@ let rec type_field ctx e i p mode =
 				cf_name = i;
 				cf_type = mk_mono();
 				cf_doc = None;
-				cf_meta = [];
+				cf_meta = no_meta;
 				cf_public = true;
 				cf_get = NormalAccess;
 				cf_set = (match mode with MSet -> NormalAccess | MGet | MCall -> NoAccess);
@@ -594,7 +594,7 @@ let rec type_field ctx e i p mode =
 			cf_name = i;
 			cf_type = mk_mono();
 			cf_doc = None;
-			cf_meta = [];
+			cf_meta = no_meta;
 			cf_public = true;
 			cf_get = NormalAccess;
 			cf_set = (match mode with MSet -> NormalAccess | MGet | MCall -> NoAccess);
@@ -862,6 +862,7 @@ and type_unop ctx op flag e p =
 		) in
 		match op, e.eexpr with
 		| Neg , TConst (TInt i) -> mk (TConst (TInt (Int32.neg i))) t p
+		| Neg , TConst (TFloat f) when f.[0] != '-' -> mk (TConst (TFloat ("-" ^ f))) t p
 		| _ -> mk (TUnop (op,flag,e)) t p
 	in
 	match acc with
@@ -1797,7 +1798,7 @@ let types ctx main excludes =
 			cf_get = NormalAccess;
 			cf_set = NormalAccess;
 			cf_doc = None;
-			cf_meta = [];
+			cf_meta = no_meta;
 			cf_params = [];
 			cf_expr = Some (mk (TCall (mk (TField (emain,"main")) ft null_pos,[])) r null_pos);
 		} in