Added rudimentary support for typing class-using expressions ; bug corrections.

3 files changed, 352 insertions, 132 deletions

diff --git a/src/parser.mly b/src/parser.mly
index 5594430..71c7842 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -123,7 +123,7 @@ cls_proto:
 	LPAREN args = separated_list(COMMA, typed_var) RPAREN
 	{ {p_ret_type = None;
 		p_name = cls;
-		p_class = Some cls;
+		p_class = None;
 		p_args = args;
 		p_loc = $startpos, $endpos } }
 ;
diff --git a/src/pretty_typing.ml b/src/pretty_typing.ml
index 709611b..26e5b49 100644
--- a/src/pretty_typing.ml
+++ b/src/pretty_typing.ml
@@ -105,12 +105,11 @@ let proto_str p =
 
 let print_prog p =
 	List.iter (function
-		| TDGlobal((ty,b),i) -> let addr = (if b then "&" else "") in
-					print_string ("decl " ^ addr ^ i ^ " : " ^ (var_type_str ty) ^ "\n")
+		| TDGlobal(ty,i) -> 
+					print_string ("decl " ^ i ^ " : " ^ (var_type_str ty) ^ "\n")
 		| TDFunction(p,b) -> print_string (proto_str p ^"\n");
 			print_block 0 b
 		| TDClass(c) -> () (* print_class_decl c  *)
-		| TDNothing -> ()
 		) 
-	  p
+	p.prog_decls
 
diff --git a/src/typing.ml b/src/typing.ml
index d39bf3e..53afe0f 100644
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -1,8 +1,8 @@
 open Ast
 
 (* Gestion des erreurs *)
-exception LocError of loc * string
 exception Error of string
+exception LocError of loc * string
 let ty_assert x k = if not x then raise (Error (k))
 let ty_error k = raise (Error (k))
 let err_add_loc loc f =
@@ -10,10 +10,13 @@ let err_add_loc loc f =
 	with
 		| Error(k) -> raise (LocError(loc, k))
 		| LocError(_, _) as e -> raise e
-		| Assert_failure (k, a, b) -> raise (LocError (loc, "(unexpected) Assertion failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b)))
+		| Assert_failure (k, a, b) -> raise (LocError (loc,
+			"(unexpected) Assertion failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b)))
 		| Not_found -> raise (LocError (loc, "(unexpected) Not found"))
 		| Invalid_argument(k) -> raise (LocError (loc, "(unexpected) Invalid argument: "^k))
-		| _ -> raise (LocError (loc, "(unexpected) Other error")
+		| Match_failure(k, a, b) -> raise (LocError (loc,
+			"(unexpected) Match failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b)))
+		| _ -> raise (LocError (loc, "(unexpected) Other error"))
 
 (* AST typés *)
 
@@ -45,14 +48,14 @@ and texpr_desc =
   | TEUnary of unop * texpression
   | TEBinary of texpression * binop * texpression
   | TEMember of texpression * ident
-  | TENew of tident * texpression list
+  | TENew of tcls * tproto option * texpression list
 
-type tstr_expression =
+and tstr_expression =
 	| TSEExpr of texpression
 	| TSEStr of string
 
 
-type tstatement = {
+and tstatement = {
 	ts_loc: loc;
 	ts_desc: ts_desc;
 	}
@@ -66,12 +69,13 @@ and ts_desc =
 	| TSReturn of texpression option
 	| TSDeclare of type_ref * ident
 	| TSDeclareAssignExpr of type_ref * ident * texpression
-	| TSDeclareAssignConstructor of var_type * ident * tident * texpression list (* a faire *)
+	| TSDeclareAssignConstructor of type_ref * ident * tident * texpression list (* a faire *)
 (* Type of variable, variable name, constructor class name, constructor arguments *)
 	| TSWriteCout of tstr_expression list
 and tblock = tstatement list
 
 and tproto = {
+	tp_virtual : bool;	(* only used for class methods *)
 	tp_loc : loc;
 	tp_name : ident;	
 	tp_class : tident option; (* p_class = none : standalone function *)
@@ -79,48 +83,48 @@ and tproto = {
 	tp_args : (type_ref * ident) list;
 }
 
-type decl_ident = (* type d'un identifieur *)
-  | Var of type_ref
-  | Fun of tproto * tblock
-and env = decl_ident Smap.t (* string -> decl_ident *)
-
-type tcls_mem =
-	| TCVar of var_type * ident
-	| TCMethod of tproto
-	| TCVirtualMethod of tproto
-
-type tcls = {
+and tcls = {
 	tc_name : tident;
-	tc_supers : tident list option;
-	tc_members : tcls_mem list;
+	tc_supers : tident list;
+	tc_members : typ Smap.t;
+	tc_methods : tproto list;
+}
+
+type env = {
+	e_globals : typ Smap.t;
+	e_funs : tproto list;
+	e_classes : tcls Smap.t;
+}
+and benv = {
+	b_pe : env;
+	b_locals : type_ref Smap.t;
+	b_class : tcls option;
 }
 
+
 type tdeclaration =
-	| TDGlobal of (type_ref * ident)
+	| TDGlobal of (typ * ident)
 	| TDFunction of (tproto * tblock)
 	| TDClass of tcls
-	| TDNothing
 
-type tprogram = tdeclaration list
+type tprogram = {
+	prog_decls : tdeclaration list;
+	prog_env : env;
+}
 
 (* Quelques fonctions utiles : *)
 
 let find_v i env =
-  match Smap.find i env with
-    | Var tr -> tr
-    | _ -> ty_error ("Not a variable : " ^ i)
-
-let find_f i env =
-  match Smap.find i env with
-    | Fun (p,t) -> (p,t)
-	| _ -> ty_error ("Not a function : " ^ i)
+  try Smap.find i env.e_globals with Not_found -> ty_error ("No such global variable: " ^ i)
 
-
-let rec bf = function			(* true si bien formé *)
-  | T_Int -> true
-  | TClass _ -> true
-  | TPoint t -> bf t
-  | _ -> false
+let rec bf env t =
+  let rec aux = function			(* true si bien formé *)
+	  | T_Int -> true
+	  | TClass n ->
+		Smap.mem n env.e_classes
+	  | TPoint t -> aux t
+	  | _ -> false
+	in aux t
 
 let num = function
   | T_Int -> true
@@ -143,14 +147,54 @@ let build_type_or_ref vt = (* vt -> typ,bool = tr, true si ref *)
     | TRef vt -> (see vt),true (* indique qu'il s'agit d'une ref *)
     | vt -> (see vt),false
 
-let rec subtype a b = match a, b with
-	| T_Int, T_Int -> true
-	| T_Void, T_Void -> true
-	| Typenull, TPoint(_) -> true
-	| TPoint(ka), TPoint(kb) -> subtype ka kb
-	| TClass(i), TClass(j) -> ty_error "Classes not implemented (in subtype a b)"
-	| _ -> false
-
+let rec subtype_d env a b = match a, b with (* returns distance *)
+	| T_Int, T_Int -> true, 0
+	| T_Void, T_Void -> true, 0
+	| Typenull, TPoint(_) -> true, 0
+	| TPoint(ka), TPoint(kb) -> subtype_d env ka kb
+	| TClass(i), TClass(j) ->
+		if i = j then true, 0
+		else begin try let c = Smap.find i env.e_classes in
+			begin let d = ref None in
+			List.iter (fun s -> match subtype_d env (TClass s) (TClass j) with
+				| false, _ -> ()
+				| true, n -> d := match !d with | None -> Some n | Some d -> Some (if d < n then d else n))
+				c.tc_supers;
+			match !d with
+			| Some d -> true, d+1
+			| None -> false, 0
+			end
+		with | Not_found -> false, 0 end
+	| _ -> false, 0
+let subtype env a b = fst (subtype_d env a b)
+
+
+(* pour la surcharge de fonctions *)
+let closest_proto env arg_type_list fun_list =
+	let p = ref None in
+	List.iter (fun f ->
+		let proto = f in
+		try
+		let k = List.fold_left2
+			(fun d (t_a, t_a_ref) (t_p, t_p_ref) -> match d with
+				| None -> None
+				| Some d ->
+					if t_p_ref && (not t_a_ref) then None else
+					match subtype_d env t_a t_p with
+					| false, _ -> None
+					| true, d_a -> Some (d + d_a))
+			(Some 0) arg_type_list (List.map fst proto.tp_args) in
+		match k with
+		| None -> ()
+		| Some d -> match !p with
+			| None -> p := Some(d, f)
+			| Some(dd, _) -> if (d < dd) then p := Some(d, f)
+							else if (d = dd) then ty_error "Ambiguous overload"
+		with Invalid_argument _ -> ()) fun_list;
+	match !p with
+	| None -> None
+	| Some(_, f) -> Some f
+	
 
 (* -------------------------------------------- *)
 (* On passe aux choses sérieuses *)
@@ -169,23 +213,37 @@ and get_expr env e = (* expression -> texpression,(ty,b) *)
   let (ty,b,_) = te.type_expr in
   (te,(ty,b))
 
-and compute_type env e = match e.e_desc with (* expression -> te_desc,(typ,ref?,left?) *)
+and compute_type env e =
+	let e_this = 
+		{	te_loc = e.e_loc;
+			te_desc = TEThis;
+			type_expr = TClass(match env.b_class with | Some c -> c.tc_name | None -> "#"), false, true } in
+	match e.e_desc with (* expression -> te_desc,(typ,ref?,left?) *)
     | EInt n -> TEInt n, (T_Int,false,false) 
     (* false, : pas une ref, pas une val gauche*)
     | EBool b -> let n = (if b then 1 else 0) in
 		 TEInt n, (T_Int,false,false)
     | ENull -> TENull, (Typenull,false,false)
     | EIdent i -> 
-      (try let ty,b = find_v i env in (* pb avec (i,bool) *)
-	  ty_assert (bf ty) "Malformed type"; (* règle champs p4 *)
-	   TEIdent i,(ty,b,true)
-       with Not_found -> ty_error ("Unknown identifier " ^ i)
-      )
+		begin try
+			let t, r = Smap.find i env.b_locals in
+			TEIdent i, (t, r, true)
+		with Not_found ->
+			try match env.b_class with
+			| Some k -> let ty = Smap.find i k.tc_members in
+				TEMember(e_this, i),
+				 (ty, false, true)
+			| None -> raise Not_found
+		with Not_found ->
+			try let t = Smap.find i env.b_pe.e_globals in
+			TEIdent i, (t, false, true)
+		with Not_found -> ty_error ("Undeclared identifier: " ^ i)
+		end
     | EAssign (e1,e2) -> let te1,(ty1,r3,b3) = get_expr0 env e1 in
 			 let te2,(ty2,_,_) = get_expr0 env e2 in
 			 ty_assert (b3 || r3) "Can only assign to lvalue";
 			 ty_assert (num ty1) "Cannot assign to non-numeric type (pointer type is numeric)";
-			 ty_assert (subtype ty2 ty1) "Incompatible types in assign";
+			 ty_assert (subtype env.b_pe ty2 ty1) "Incompatible types in assign";
 			 		(* type num et ref compatibles ?*)
 			 (TEAssign (te1,te2) ),(ty1,false,false)
     | EUnary (op,e) -> let te,(ty,b1,b2) = get_expr0 env e in
@@ -210,7 +268,8 @@ and compute_type env e = match e.e_desc with (* expression -> te_desc,(typ,ref?,
 			    let te2,(ty2,_,b2) = get_expr0 env e2 in
 			    (match op with
 			      | Equal | NotEqual -> 
-					ty_assert (ty1 = ty2) "Can only apply == or != to two values of same type";
+					ty_assert ((subtype env.b_pe ty1 ty2) || (subtype env.b_pe ty2 ty1)) 
+						"Can only apply == or != to two values of compatible type";
 					ty_assert (num ty1) "Can only apply == or != to pointers"
 			      | Lt | Le | Gt | Ge
 			      | Add | Sub | Mul | Div | Modulo
@@ -219,35 +278,72 @@ and compute_type env e = match e.e_desc with (* expression -> te_desc,(typ,ref?,
 					ty_assert (ty2 = T_Int) "Right operand of binop is not integer"
 			    ); (* vérifs *)
 			    TEBinary(te1,op,te2),(T_Int,false,false)
-    | ECall (e,e_list) -> let name = (match e.e_desc with
-			    | EIdent i -> i
-			    | _ -> ty_error "Calling something that is not a function") in
-			  let tproto,tblock = find_f name env in (* chope la fonction *)
-			  let args_proto = List.map fst tproto.tp_args in 
-			  let args_values = List.map (get_expr0 env) e_list in
-			  begin try
-			  	List.iter2 
-					(fun arg ty_proto ->
-						let _,(ty,r,l) = arg in
-						let pty,pr = ty_proto in
-						ty_assert (if pr then r || l else true) "Expected referencable value as argument";
-						ty_assert (subtype ty pty) "Invalid argument type"
-					) args_values args_proto
-			  with
-			  | Invalid_argument _ -> ty_error "Incorrect arity for function call"
-			  end;
+    | ECall (e,e_list) ->
+		(* TODO : look also within parent classes *)
+			let obj, name, candidates = (match e.e_desc with
+			    | EIdent i ->
+					let funs = List.filter (fun p -> p.tp_name = i) env.b_pe.e_funs in
+					begin match env.b_class with
+					| None -> None, i, funs
+					| Some k ->
+						begin match List.filter (fun p -> p.tp_name = i) k.tc_methods with
+						| [] -> None, i, funs
+						| l -> Some e_this, i, l
+						end
+					end
+				| EMember(e, i) ->
+					let e = type_expr env e in
+					let c = match e.type_expr with
+					| TClass(k), a, b when a || b ->
+						begin try Smap.find k env.b_pe.e_classes with
+							Not_found -> ty_error ("Unknown class " ^ k ^ " (should not happen)") end
+					| _ -> ty_error "Invalid argument type for method call (not a class, or not a lvalue)"
+					in
+					Some e, i, List.filter (fun p -> p.tp_name = i) (c.tc_methods)
+			    | _ -> ty_error "Calling something that is neither a function nor a method") in
+			let args_values = List.map (get_expr0 env) e_list in
+			let tproto = match candidates with
+			| [] -> ty_error ("No such function: " ^ name)
+			| l ->
+				(* handle overload *)
+			  let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in
+			  let f = closest_proto env.b_pe args_types candidates in
+			  begin match f with
+			  | None -> ty_error "No corresponding function"
+			  | Some(p) -> p
+			  end
+			in
 			  (* vérif ici pour adresse/valeur, ici on test seulement
-			     que ce sont les mêmes types, pas d'adressage de pris en compte *)
+				 que ce sont les mêmes types, pas d'adressage de pris en compte *)
 			  let l_te = List.map fst args_values in 
 			  (* que les te de e_list*)
 			  let ty,b = match tproto.tp_ret_type with
-			    | None -> assert false (* no return type only happens for constructors, and
+				| None -> assert false (* no return type only happens for constructors, and
 											constructors cannot be called as functions *)
-			    | Some (ty,b) -> ty,b in
+				| Some (ty,b) -> ty,b in
 			  TECallFun(name,l_te),(ty,b,false)
-    | EMember _ -> ty_error "Not implemented"
-    | ENew _ -> ty_error "Not implemented"
-    | EThis -> ty_error "Not implemented"
+    | EMember _ -> ty_error "Not implemented (member)"
+    | ENew (cls_name, args) -> 
+		begin try let c = Smap.find cls_name env.b_pe.e_classes in
+			let args_values = List.map (get_expr0 env) args in
+			  let args_types = List.map (fun (e, (t, r, l)) -> t, r||l) args_values in
+			let candidates = List.filter (fun p -> p.tp_ret_type = None) c.tc_methods in
+			match candidates with
+			| [] ->
+				ty_assert (args = []) "Only default constructor exists and it has 0 arguments";
+				TENew(c, None, []), (TPoint(TClass(cls_name)), false, false)
+			| _ ->
+				let proto = closest_proto env.b_pe args_types candidates in
+				match proto with
+				| Some (p) ->
+					(* closest_proto makes sure the prototypes match, no problem here *)
+					let l_te = List.map fst args_values in
+					TENew(c, Some p, l_te), (TPoint(TClass(cls_name)), false, false)
+				| None -> ty_error "No matching prototype"
+		with
+		| Not_found -> ty_error ("No such class: " ^ cls_name)
+		end
+    | EThis -> ty_error "Not implemented (this)"
 
 
 (* Statements *)
@@ -269,8 +365,7 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des
   | SReturn (Some e0) ->  let te,(ty,r) = get_expr env e0 in
   		let rty, rref = ret_type in
   				ty_assert (rty = ty) "Invalid return type";
-				ty_assert (if rref then r else false) "Function must return reference";
-  			
+				ty_assert (if rref then r else true) "Function must return reference";
 			  TSReturn (Some te), env 
   | SIf (e,s1,s2) ->  let te,(ty,_) = get_expr env e in
 		      let ts1,ty1 = type_stm ret_type env s1 in (* vérifs règle *)
@@ -295,17 +390,23 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des
 		   TSWhile(te,ts),env
   (* pq while n'est pas dans les règles données ? *)
   | SDeclare(vt,i) -> let ty,b = build_type_or_ref vt in
-		      ty_assert (bf ty) "Malformed type";
-		      ty_assert (not (Smap.mem i env) ) "Variable redefinition";
-		      let env0 = Smap.add i (Var (ty,b)) env in
+		      ty_assert (bf env.b_pe ty) "Malformed type";
+		      ty_assert (not (Smap.mem i env.b_locals) ) "Variable redefinition";
+		      let env0 =
+			  {	b_pe = env.b_pe;
+			  	b_locals = Smap.add i (ty,b) env.b_locals;
+				b_class = env.b_class } in
 		      TSDeclare( (ty,b) ,i) , env0
   | SDeclareAssignExpr(vt,i,e) -> let ty,b = build_type_or_ref vt in
-				  ty_assert (bf ty) "Malformed type";
-				  ty_assert (not (Smap.mem i env)) "Variable redefinition";
+				  ty_assert (bf env.b_pe ty) "Malformed type";
+				  ty_assert (not (Smap.mem i env.b_locals)) "Variable redefinition";
 				  let te,(tye,r,l) = get_expr0 env e in
 				  ty_assert (if b  then r || l else true) "Can only assigne lvalue/reference to reference type var";
-				 (* assert tye<ty;*)
-				  let env0 = Smap.add i (Var (ty,b) ) env in
+				  ty_assert (subtype env.b_pe tye ty) "Invalid data type for assign.";
+				  let env0 = 
+				  {	b_pe = env.b_pe;
+				  	b_locals = Smap.add i (ty,b) env.b_locals;
+					b_class = env.b_class } in
 				  TSDeclareAssignExpr( (ty,b) ,i,te) , env0
   | SWriteCout(str_e_list) -> 
     let args = 
@@ -318,12 +419,12 @@ and compute_type_stm ret_type env s = match s.s_desc with (* statement -> ts_des
 	str_e_list 
     in
     TSWriteCout(args) , env
-  | SDeclareAssignConstructor(vt,i,ti,e_l) -> TSEmpty,env (* a faire *)
+  | SDeclareAssignConstructor(vt,i,ti,e_l) -> ty_error "TODO"
 		    
 and build_block ret_type env b = (* utilisé ds compute_type_stm et def_global_fun *)
   let two_stms (env,l) s =
-    let ts,ty = type_stm ret_type env s in
-    (ty,(ts::l)) in
+    let ts,env2 = type_stm ret_type env s in
+    (env2,(ts::l)) in
   let ty_final,ts_list = List.fold_left two_stms (env,[]) b in 
   (* verif si b bien typé (règle i1;i2) et construit le te-block*)
   TSBlock (List.rev ts_list),env
@@ -333,60 +434,180 @@ and get_block ret_type env b =
     | TSBlock tb -> tb
     | _ -> assert false
 
-(* Autres *)
+(* Déclarations de fonction *)
+
+let parse_args env a =
+	let args = List.map
+		(fun (t, i) ->
+			let t, r = build_type_or_ref t in
+			ty_assert (bf env t) ("Malformed argument type for argument " ^ i ^ ".");
+			(t, r), i)
+		a in
+	let rec aux = function
+		| [] -> ()
+		| p::q -> ty_assert (not (List.mem p q)) ("Argument name appears twice : " ^ p); aux q
+	in aux (List.map snd args);
+	args
  
-let get_fun env p b = (* p : proto   b : block -> name,Fun( ...)*)
+let get_fun env p b = (* p : proto   b : block -> tp, tb, env2*)
+  assert (p.p_class = None);
   let name = p.p_name in
-  let ty_args = 
-    List.map (* liste des arguments tr*ident *)
-      (fun (vt,i) -> let tr = build_type_or_ref vt in
-		     (tr,i)              )
-      p.p_args
-  in
-(* vérif que les xi sont distincts, enlever '&' possible
-pour traiter les ref, en fait fait quand on appelle sur proto.p_args *)
-  let ids = List.map snd p.p_args in (* juste les ident*)
-  let aux = function
-  	| [] -> ()
-	| p::q -> ty_assert (not (List.mem p q)) ("Argument name appears twice : " ^ p)
-  in aux ids;
-  List.iter (fun ((ty,_),_) -> assert( bf ty ) ) ty_args; 
-(* types st bf*)
-  let ret_type = build_type_or_ref (match p.p_ret_type with | Some k -> k | None -> assert false (* not implemented *) ) in
-  let contexte = List.fold_left (* tr = (ty,ref?) *)
-    (fun envir (tr,i) -> Smap.add i (Var tr) envir)
-    env
-    ty_args
+  let ty_args = parse_args env p.p_args in
+  (* Check there is not already a function with similar prototype *)
+  let args_type = List.map fst ty_args in
+  ty_assert (not (List.exists
+	(fun p -> p.tp_name = name && (List.map fst p.tp_args) = args_type) env.e_funs))
+	("Redefinition of function: " ^ name);
+
+  let ret_type = build_type_or_ref
+  (match p.p_ret_type with
+	| Some k -> k
+	| None -> ty_error "Internal error (function with no return type)" ) in
+
+  (* Add to env *)
+  let tproto = { tp_loc = p.p_loc ; tp_name = name ; tp_class = None ; tp_virtual = false ;
+		 tp_ret_type = Some ret_type ; tp_args = ty_args; } in
+  let env2 = 
+		{	e_globals = env.e_globals;
+			e_funs = tproto::(env.e_funs);
+			e_classes = env.e_classes; } in
+  (* Build local env *)
+  let locales = List.fold_left (* tr = (ty,ref?) *)
+	(fun envir (tr,i) -> Smap.add i tr envir)
+	Smap.empty
+	ty_args
   in (* contexte ds l'instruction *)
+  let contexte = { b_pe = env2; b_locals = locales; b_class = None } in
   let tb = get_block ret_type contexte b in (* vérif instructions typées*)
-  let tproto = { tp_loc = p.p_loc ; tp_name = name ; tp_class = None ;
-		 tp_ret_type = Some ret_type ; tp_args = ty_args; }
-  in
-  name,tproto,tb
+  tproto,tb, env2
+
+(* Déclarations de classes *)
+
+let rec compute_tclass env c = 
+	let name = c.c_name in
+	ty_assert (not (Smap.mem name env.e_classes)) ("Redeclaration of class " ^name^".");
+	let supers = match c.c_supers with | None -> [] | Some k -> k in
+	List.iter (fun n ->
+		ty_assert (Smap.mem n env.e_classes)
+				("Super " ^ n ^ " does not exist or is not a class.")) supers;
+	let cls_tmp = {tc_name = name; tc_supers = supers; tc_members = Smap.empty; tc_methods = [] } in
+	let t_env = {
+		e_globals = env.e_globals;
+		e_funs = env.e_funs;
+		e_classes = (Smap.add name cls_tmp env.e_classes); } in
+	let mem, meth = List.fold_left
+		(fun (mem, meth) n -> match n with
+			| CVar(t, i) ->
+				let t, r = build_type_or_ref t in
+				ty_assert (not r) "Class members cannot be references.";
+				ty_assert (bf t_env t) ("Malformed type for member " ^ i ^ ".");
+				ty_assert (t <> TClass(name)) "Class cannot contain itself as a member.";
+				ty_assert (not (Smap.mem i mem)) ("Redefinition of class member " ^ i ^ " in class " ^ name ^ ".");
+				(Smap.add i t mem, meth)
+			| CMethod(p) ->
+				let m = err_add_loc p.p_loc (fun () -> (build_method t_env name meth false p)) in
+				mem, m::meth
+			| CVirtualMethod(p) ->
+				let m = err_add_loc p.p_loc (fun () -> (build_method t_env name meth true p)) in
+				mem, m::meth
+		) (Smap.empty, []) c.c_members in
+	{	tc_name = name;
+		tc_supers = supers;
+		tc_members = mem;
+		tc_methods = meth; }
+and build_method env cls_name cls_mems virt proto =
+	ty_assert (proto.p_class = None) "Overqualification in prototype.";
+	ty_assert (proto.p_ret_type <> None || proto.p_name = cls_name) "Invalid name for constructor";
+	(* Make sure prototype is well formed *)
+	let args = parse_args env proto.p_args in
+	(* TODO Make sure method is compatible with parents and other declarations *)
+	(* Check return type *)
+	let ret_type = match proto.p_ret_type with
+		| Some k -> Some (build_type_or_ref k)
+		| None -> None in
+	{	tp_virtual = virt;
+		tp_loc = proto.p_loc;
+		tp_name = proto.p_name;
+		tp_class = Some(cls_name);
+		tp_ret_type = ret_type;
+		tp_args = args;
+	}
+
+let get_method env proto block = 	(* return : TDFunction *)
+	match proto.p_class with
+	| None -> assert false
+	| Some(cls_name) ->
+	try let c = Smap.find cls_name env.e_classes in
+		let args = parse_args env proto.p_args in
+		let ret_type = match proto.p_ret_type with
+			| Some k -> Some (build_type_or_ref k)
+			| None -> None in
+		(* Find prototype in class *)
+		begin try let cproto = List.find 
+				(fun p -> p.tp_args = args && p.tp_ret_type = ret_type && p.tp_name = proto.p_name) c.tc_methods
+			in
+			let locals = List.fold_left
+				(fun env (tr, i) -> Smap.add i tr env) Smap.empty args in
+			let contexte = {
+				b_pe = env;
+				b_locals = locals;
+				b_class = Some c; } in
+			let tb = get_block (match ret_type with | None -> T_Void, false | Some k -> k) contexte block in
+			{	tp_virtual = cproto.tp_virtual;
+				tp_loc = proto.p_loc;
+				tp_name = proto.p_name;
+				tp_class = proto.p_class;
+				tp_ret_type = ret_type;
+				tp_args = args }, tb
+		with
+		| Not_found -> ty_error ("Implementation corresponds to no declared method of class " ^ cls_name)
+		end
+	with
+	| Not_found -> ty_error (cls_name ^ " is not defined.")
+	
+(* Partie générique *)
 
 let compute_decl env d = 
 	err_add_loc (d.d_loc) (fun () ->
 		match d.d_desc with
-		  | DGlobal(t,i) -> let tr = build_type_or_ref t in
-				ty_assert (bf (fst tr)) ("Malformed type for global var " ^ i);
-		  		ty_assert (not (Smap.mem i env)) ("Redeclaration of " ^ i);
-					(TDGlobal(tr,i)) , (Smap.add i (Var tr) env)
+		  | DGlobal(t,i) -> let tr, r = build_type_or_ref t in
+				ty_assert (bf env tr) ("Malformed type for global var " ^ i);
+				ty_assert (not r) "Global cannot be reference";
+		  		ty_assert (not (Smap.mem i env.e_globals)) ("Redeclaration of " ^ i);
+				ty_assert (not (List.exists (fun p -> p.tp_name = i) env.e_funs)) ("Redeclaration of: " ^ i ^ ", was previously a function");
+				(TDGlobal(tr,i)) , 
+				{	e_globals = (Smap.add i tr env.e_globals);
+					e_funs = env.e_funs;
+					e_classes = env.e_classes }
 		  (* on voudrait une liste de ident pr decl plsr en meme temps *)
-		  | DFunction (p,b) -> let name,tp,tb = get_fun env p b in
-		  				ty_assert (not (Smap.mem name env)) ("Redeclaration of " ^ name);
-					   (TDFunction (tp,tb) ) , (Smap.add name (Fun (tp,tb)) env)
-		  | DClass c -> ty_error "Not implemented : classes" (* TODO *)
+		  | DFunction (p,b) ->
+		  	ty_assert (not (Smap.mem p.p_name env.e_globals)) ("Redeclaration of: " ^ p.p_name ^ ", was previously a global variable");
+		  	begin match p.p_class with
+			| None ->
+				let tp, tb, env2 = get_fun env p b in
+				TDFunction(tp, tb), env2
+			| Some _ ->
+				let tp, tb = get_method env p b in
+				(TDFunction(tp, tb)), env(* env is not modified *)
+			end
+		  | DClass c ->
+		  	let tc = compute_tclass env c in
+		  	(TDClass tc),
+			{	e_globals = env.e_globals;
+				e_funs = env.e_funs;
+				e_classes = Smap.add c.c_name tc env.e_classes; }
 		  )
 
 let prog p =
-  let l = (
+  let decls, env = (
     List.fold_left 
-      (fun list decl  -> let (td,env) = List.hd list in
-			 (compute_decl env decl)::list         )
-      [(TDNothing,Smap.empty)]
+      (fun (decls, env) decl ->
+	  	let decl_p, env2 = compute_decl env decl in
+		decl_p::decls, env2)
+      ([],{ e_globals = Smap.empty; e_funs = []; e_classes = Smap.empty })
       p
   ) in
-  List.map fst l
+  { prog_decls = decls; prog_env = env }