فهرست منبع

added some positions and little change in structures.

Nicolas Cannasse 20 سال پیش
والد
کامیت
c86a9e4bfa
3فایلهای تغییر یافته به همراه50 افزوده شده و 39 حذف شده
  1. 17 20
      genneko.ml
  2. 10 2
      type.ml
  3. 23 17
      typer.ml

+ 17 - 20
genneko.ml

@@ -158,9 +158,7 @@ and gen_expr e =
 	| TField (e2,f) ->
 		gen_closure p e.etype (gen_expr e2) f
 	| TType t ->
-		(match t with
-		| TClassDecl c -> gen_type_path p c.cl_path
-		| TEnumDecl e -> gen_type_path p e.e_path)
+		gen_type_path p (type_path t)
 	| TParenthesis e ->
 		(EParenthesis (gen_expr e),p)
 	| TObjectDecl fl ->
@@ -263,16 +261,16 @@ let gen_method c acc =
 		| TFunction _ -> ((if c.cf_name = "new" then "__construct__" else c.cf_name), gen_expr e) :: acc
 		| _ -> acc
 
-let gen_class p c =	
-	let clpath = gen_type_path null_pos (fst p,"@" ^ snd p) in
-	let stpath = gen_type_path null_pos p in
-	let esuper = match c.cl_super with None -> null null_pos | Some (c,_) -> gen_type_path null_pos (fst c.cl_path,"@" ^ snd c.cl_path) in
+let gen_class c =	
+	let p = pos c.cl_pos in
+	let clpath = gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path) in
+	let stpath = gen_type_path p c.cl_path in
+	let esuper = match c.cl_super with None -> null p | Some (c,_) -> gen_type_path p (fst c.cl_path,"@" ^ snd c.cl_path) in
 	let fnew = (match c.cl_constructor with
 	| Some f ->
 		(match follow f.cf_type with
 		| TFun (args,_) ->
 			let params = nparams args in
-			let p = null_pos in
 			gen_method f ["new",(EFunction (params,(EBlock [
 				(EVars ["@o",Some (call p (builtin p "new") [clpath])],p);
 				(call p (builtin p "call") [field p (this p) "__construct__"; ident p "@o"; array p (List.map (ident p) params)]);
@@ -286,7 +284,6 @@ let gen_class p c =
 		let f = PMap.find "toString" c.cl_fields in
 		match follow f.cf_type with
 		| TFun ([],_) ->
-			let p = null_pos in
 			["__string",(EFunction ([],(EBlock [
 				EReturn (Some (field p (call p (field p (this p) "toString") []) "__s")),p
 			],p)),p)]
@@ -296,13 +293,12 @@ let gen_class p c =
 	) in	
 	let estat = (EBinop ("=",
 		stpath,
-		(EObject (PMap.fold gen_method c.cl_statics fnew),null_pos)
-	),null_pos) in
-	let p = null_pos in
+		(EObject (PMap.fold gen_method c.cl_statics fnew),p)
+	),p) in
 	let eclass = (EBinop ("=",
 		clpath,
 		call p (builtin p "new") [esuper]
-	),null_pos) in
+	),p) in
 	let interf = array p (List.map (fun (c,_) -> gen_type_path p c.cl_path) c.cl_implements) in
 	let magic = ("__class__", call p (builtin p "array") [stpath; interf; match c.cl_super with None -> null p | Some _ -> field p esuper "__class__"]) in
 	let methods = PMap.fold gen_method c.cl_fields fstring in
@@ -323,21 +319,22 @@ let gen_enum_constr c =
 			array p [str p c.ef_name]
 	)
 
-let gen_enum p e =
+let gen_enum e =
+	let p = pos e.e_pos in
 	(EBinop ("=",
-		gen_type_path null_pos p,
-		(EObject (pmap_list gen_enum_constr e.e_constrs),null_pos)
+		gen_type_path p e.e_path,
+		(EObject (pmap_list gen_enum_constr e.e_constrs),p)
 	),null_pos)
 
 let gen_type (p,t) =
 	match t with
 	| TClassDecl c -> 
 		if c.cl_extern then
-			null null_pos
+			null (pos c.cl_pos)
 		else
-			gen_class p c
+			gen_class c
 	| TEnumDecl e -> 
-		gen_enum p e
+		gen_enum e
 
 let gen_static_vars (_,t) =
 	match t with
@@ -367,7 +364,7 @@ let gen_packages h ((p,_),t) =
 		| x :: l ->
 			let path = acc @ [x] in
 			if not (Hashtbl.mem h path) then begin
-				let p = null_pos in
+				let p = pos (match t with TClassDecl c -> c.cl_pos | TEnumDecl e -> e.e_pos) in
 				let e = (EBinop ("=",gen_type_path p (acc,x),call p (builtin p "new") [null p]),p) in
 				Hashtbl.add h path ();
 				e :: loop path l

+ 10 - 2
type.ml

@@ -86,6 +86,7 @@ and tclass_field = {
 
 and tclass = {
 	cl_path : module_path;
+	cl_pos : Ast.pos;
 	mutable cl_extern : bool;
 	mutable cl_interface : bool;
 	mutable cl_types : (string * t) list;
@@ -105,6 +106,7 @@ and tenum_field = {
 
 and tenum = {
 	e_path : module_path;
+	e_pos : Ast.pos;
 	mutable e_types : (string * t) list;
 	mutable e_constrs : (string , tenum_field) PMap.t;
 }
@@ -115,7 +117,7 @@ and module_type =
 
 type module_def = {
 	mpath : module_path;		
-	mtypes : (module_path * module_type) list;
+	mtypes : module_type list;
 }
 
 let mk e t p = { eexpr = e; etype = t; epos = p }
@@ -124,9 +126,10 @@ let mk_mono() = TMono (ref None)
 
 let rec t_dynamic = TDynamic t_dynamic
 
-let mk_class path =
+let mk_class path pos =
 	{
 		cl_path = path;
+		cl_pos = pos;
 		cl_extern = false;
 		cl_interface = false;
 		cl_types = [];
@@ -164,6 +167,11 @@ and s_type_params ctx = function
 	| [] -> ""
 	| l -> "<" ^ String.concat ", " (List.map (s_type ctx) l) ^ ">"
 
+let type_path t =
+	match t with 
+	| TClassDecl c -> c.cl_path
+	| TEnumDecl e -> e.e_path
+
 let rec follow t =
 	match t with
 	| TMono r ->

+ 23 - 17
typer.ml

@@ -30,7 +30,7 @@ type context = {
 	mutable untyped : bool;
 	(* per-module *)
 	current : module_def;
-	mutable local_types : (module_path * module_type) list;
+	mutable local_types : module_type list;
 	(* per-class *)
 	mutable curclass : tclass;
 	mutable type_params : (string * t) list;
@@ -74,7 +74,10 @@ let unify ctx t1 t2 p =
 let load_type_def ctx p tpath =
 	let no_pack = fst tpath = [] in
 	try
-		snd (List.find (fun (tp,_) -> tp = tpath || (no_pack && snd tp = snd tpath)) ctx.local_types)
+		List.find (fun t -> 
+			let tp = type_path t in
+			tp = tpath || (no_pack && snd tp = snd tpath)
+		) ctx.local_types
 	with
 		Not_found ->
 			let tpath, m = (try 
@@ -86,7 +89,7 @@ let load_type_def ctx p tpath =
 				| Exit -> tpath, load ctx tpath p
 			) in
 			try
-				snd (List.find (fun (tp,_) -> tp = tpath) m.mtypes)
+				List.find (fun t -> type_path t = tpath) m.mtypes
 			with
 				Not_found -> error ("Module " ^ s_type_path tpath ^ " does not define type " ^ snd tpath) p
 
@@ -187,13 +190,14 @@ let type_type_params ctx path p (n,flags) =
 		(* build a phantom enum *)
 		let e = {
 			e_path = (fst path @ [snd path],n);
+			e_pos = p;
 			e_types = [];
 			e_constrs = PMap.empty;
 		} in
 		TEnum (e,[])
 	| l ->
 		(* build a phantom class *)
-		let c = mk_class (fst path @ [snd path],n) in
+		let c = mk_class (fst path @ [snd path],n) p in
 		set_heritance ctx c (List.map (fun t -> HImplements t) l) p;
 		let add_field ctypes params _ f =
 			let f = { f with cf_type = apply_params ctypes params f.cf_type } in
@@ -307,7 +311,7 @@ let type_ident ctx i p =
 		let rec loop l =
 			match l with
 			| [] -> raise Not_found
-			| (_,t) :: l ->
+			| t :: l ->
 				match t with
 				| TClassDecl c -> 
 					loop l
@@ -1077,16 +1081,17 @@ let type_module ctx m tdecls =
 		| EImport _ -> ()
 		| EClass (name,_,_,_) ->
 			let path = decl_with_name name p in
-			let c = mk_class path in
-			decls := ((fst m,name),TClassDecl c) :: !decls
+			let c = mk_class path p in
+			decls := TClassDecl c :: !decls
 		| EEnum (name,_,_) ->
 			let path = decl_with_name name p in
 			let e = {
 				e_path = path;
+				e_pos = p;
 				e_types = [];
 				e_constrs = PMap.empty;
 			} in
-			decls := ((fst m,name), TEnumDecl e) :: !decls
+			decls := TEnumDecl e :: !decls
 	) tdecls;
 	let m = {
 		mpath = m;
@@ -1119,12 +1124,12 @@ let type_module ctx m tdecls =
 			let m = load ctx t p in
 			ctx.local_types <- ctx.local_types @ m.mtypes
 		| EClass (name,types,herits,fields) ->
-			let c = List.find (fun (_,d) -> match d with TClassDecl { cl_path = _ , n } -> n = name | _ -> false) m.mtypes in
-			let c = (match snd c with TClassDecl c -> c | _ -> assert false) in
+			let c = List.find (fun d -> match d with TClassDecl { cl_path = _ , n } -> n = name | _ -> false) m.mtypes in
+			let c = (match c with TClassDecl c -> c | _ -> assert false) in
 			delays := !delays @ check_overloading c p :: check_interfaces c p :: init_class ctx c p types herits fields
 		| EEnum (name,types,constrs) ->
-			let e = List.find (fun (_,d) -> match d with TEnumDecl { e_path = _ , n } -> n = name | _ -> false) m.mtypes in
-			let e = (match snd e with TEnumDecl e -> e | _ -> assert false) in
+			let e = List.find (fun d -> match d with TEnumDecl { e_path = _ , n } -> n = name | _ -> false) m.mtypes in
+			let e = (match e with TEnumDecl e -> e | _ -> assert false) in
 			ctx.type_params <- [];
 			e.e_types <- List.map (type_type_params ctx e.e_path p) types;
 			ctx.type_params <- e.e_types;
@@ -1180,7 +1185,7 @@ let context warn =
 		local_types = [];
 		type_params = [];
 		curmethod = "";
-		curclass = mk_class ([],"");
+		curclass = mk_class ([],"") null_pos;
 		current = empty;
 		std = empty;
 	} in
@@ -1212,7 +1217,8 @@ let types ctx main =
 	let state p = try Hashtbl.find states p with Not_found -> NotYet in
 	let statics = ref PMap.empty in
 
-	let rec loop (p,t) =
+	let rec loop t =
+		let p = type_path t in
 		match state p with
 		| Done -> ()
 		| Generating ->
@@ -1226,10 +1232,10 @@ let types ctx main =
 			types := (p,t) :: !types
 
     and loop_class p c =
-		if c.cl_path <> p then loop (c.cl_path,TClassDecl c)
+		if c.cl_path <> p then loop (TClassDecl c)
 
 	and loop_enum p e =
-		if e.e_path <> p then loop (e.e_path,TEnumDecl e)
+		if e.e_path <> p then loop (TEnumDecl e)
 
 	and walk_static_call p c name =
 		try
@@ -1304,7 +1310,7 @@ let types ctx main =
 				Not_found -> error ("Invalid -main : " ^ s_type_path cl ^ " does not have static function main") null_pos
 		);
 		let path = ([],"@Main") in
-		let c = mk_class path in
+		let c = mk_class path null_pos in
 		c.cl_statics <- PMap.add "init" {
 			cf_name = "init";
 			cf_type = mk_mono();