Merge branch 'master' of github.com:fatlevis/LPC-Projet

5 files changed, 590 insertions, 7 deletions

diff --git a/.gitignore b/.gitignore
index 3fa6770..c4ed90c 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,5 @@
+*~
+src/minic++
 _build
 *.byte
 .depend
diff --git a/src/main.ml b/src/main.ml
index c64381c..9fb4e46 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -3,6 +3,7 @@ open Lexing
 
 let parse_only = ref false
 let dump = ref false
+let dumpt = ref false
 
 let ifile = ref ""
 
@@ -15,17 +16,20 @@ let localisation pos =
 	let c = pos.pos_cnum - pos.pos_bol + 1 in
 	eprintf "File \"%s\", line %d, characters %d-%d:\n"
 		!ifile l (c-1) c
+
+let localisation2 (pos1,pos2) =
+	let l = pos1.pos_lnum in
+	let c1 = pos1.pos_cnum - pos1.pos_bol + 1 in
+	let c2 = pos2.pos_cnum - pos2.pos_bol + 1 in
+	eprintf "File \"%s\", line %d, characters %d-%d:\n"
+		!ifile l c1 c2
 	
 let options = [
 	"--parse-only", Arg.Set parse_only, "Stops after parsing of the input file.";
-	"--dump", Arg.Set dump, "Dump the AST after parsing."
+	"--dump", Arg.Set dump, "Dump the AST after parsing.";
+	"--dumpt", Arg.Set dumpt, "Dump the AST after typing."
 	]
 
-let localisation pos =
-  let l = pos.pos_lnum in
-  let c = pos.pos_cnum - pos.pos_bol + 1 in
-  eprintf "File \"%s\", line %d, characters %d-%d:\n" !ifile l (c-1) c
-
 let () =
 	Arg.parse options (set_var ifile) usage;
 
@@ -43,18 +47,25 @@ let () =
 
 	try
 		let p = Parser.prog Lexer.token buf in
+		let t = Typing.prog p in
 		close_in f;
 		
 		if !dump then Pretty.print_prog p;
+		if !dumpt then Pretty_typing.print_prog t;
 	with
 		| Lexer.Lexing_error s ->
 			localisation (Lexing.lexeme_start_p buf);
 			eprintf "Lexical analysis error: %s@." s;
 			exit 1
 		| Parser.Error -> 
-			localisation (Lexing.lexeme_start_p buf);
+		        localisation (Lexing.lexeme_start_p buf);
 			eprintf "Parsing error.@.";
 			exit 1
+		| Typing.Error (loc, msg) ->
+		  localisation2 loc;
+		  eprintf "%s" msg;
+		  exit 1
+		  
 		| _ ->
 			eprintf "Unexpected error...@.";
 			exit 2
diff --git a/src/pretty_typing.ml b/src/pretty_typing.ml
new file mode 100644
index 0000000..371b210
--- /dev/null
+++ b/src/pretty_typing.ml
@@ -0,0 +1,176 @@
+(*
+	PRETTY PRINTER
+	These functions enable the dumping of an AST
+	Used for debugging the parser.
+*)
+
+
+open Parser
+open Typing
+open Ast
+
+let token_str = function
+	| CLASS -> "class"
+	| ELSE -> "else"
+	| FALSE -> "false"
+	| FOR -> "for"
+	| IF -> "if"
+	| INT -> "int"
+	| NEW -> "new"
+	| NULL -> "NULL"
+	| PUBLIC -> "public"
+	| RETURN -> "return"
+	| THIS -> "this"
+	| TRUE -> "true"
+	| VIRTUAL -> "virtual"
+	| VOID -> "void"
+	| WHILE -> "while"
+	| IDENT(s) -> "'"^s^"'"
+	| TIDENT(s) -> "\""^s^"\""
+	| ASSIGN -> "="
+	| LOR -> "||"
+	| LAND -> "&&"
+	| EQ -> "=="
+	| NE -> "!="
+	| LT -> "<"
+	| LE -> "<="
+	| GT -> ">"
+	| GE -> ">="
+	| PLUS -> "+"
+	| MINUS -> "-"
+	| TIMES -> "*"
+	| DIV -> "/"
+	| MOD -> "%"
+	| NOT -> "!"
+	| INCR -> "++"
+	| DECR -> "--"
+	| REF -> "&"
+	(* and also : unary dereference, plus, minus *)
+	| LPAREN -> "("
+	| RPAREN -> ")"
+	| RARROW -> "->"
+	| DOT -> "."
+	(* OTHER SYMBOLZ *)
+	| SEMICOLON -> ";"
+	| DOUBLECOLON -> "::"
+	| LFLOW -> "<<"
+	| LBRACE -> "{"
+	| RBRACE -> "}"
+	| COMMA -> ","
+	| COLON -> ":"
+	(* DATAZ *)
+	| INTVAL(i) -> "#" ^ (string_of_int i)
+	| STRVAL(s) -> "`" ^ s ^ "`"
+	(* STUPIDITIEZS *)
+	| STD_COUT -> "std::cout"
+	| INCLUDE_IOSTREAM -> "#include <iostream>"
+	| EOF -> "end."
+
+let print_tok t =
+	print_string ((token_str t) ^ "\n")
+
+let csl f l =
+	List.fold_left 
+	  (fun x t -> (if x = "" then "" else x ^ ", ") ^ (f t)) "" l
+
+(* printing AST's *)
+
+let binop_str = function
+	| Equal -> "==" | NotEqual -> "!=" | Lt -> "<" | Le -> "<="
+	| Gt -> ">" | Ge -> ">=" | Add -> "+" | Sub -> "-" | Mul -> "*" | Div -> "/"
+	| Modulo -> "%" | Land -> "&&" | Lor -> "||"
+let unop_str = function
+	| PreIncr -> "++." | PostIncr -> ".++" | PreDecr -> "--." | PostDecr -> ".--"
+	| Ref -> "&" | Deref -> "*" | Not -> "!" | Minus -> "-" | Plus -> "+"
+let rec var_type_str = function
+	| T_Void -> "void" | T_Int -> "int"
+	| TPoint(k) -> "*" ^ (var_type_str k)
+	| TClass s -> ""
+	| Typenull -> "NULL"
+let rec expr_string e = match e.te_desc with
+	| TEInt(i) -> string_of_int i
+	| TENull -> "NULL"
+	| TEThis -> "this"
+	| TEIdent(i) -> i
+	| TEAssign(k, p) -> "(" ^ (expr_string k) ^ " = " ^ (expr_string p) ^ ")"
+	| TECallFun(i, f) -> i ^ "(" ^ (csl expr_string f) ^ ")"
+(* ici, le second ast a changé par rapport au premier *)
+	| TEUnary(e, f) -> (unop_str e) ^ (expr_string f)
+	| TEBinary(e1, o, e2) -> "(" ^ (expr_string e1) ^ " " ^ (binop_str o) ^ " " ^ (expr_string e2) ^ ")"
+(*	| TEMember(e1, x) -> "(" ^ (expr_string e1) ^ ")." ^ x
+	| TENew(c, arg) -> "new " ^ c ^ " (" ^ (csl expr_string arg) ^ ")"*)
+	| _ -> ""
+
+let rec print_stmt l x =
+	for i = 1 to l do print_string " " done;
+	match x.ts_desc with 
+	| TSEmpty -> print_string ";\n"
+	| TSExpr(e) -> print_string ((expr_string e) ^ "\n")
+	| TSIf(e, a, b) -> print_string ("if " ^ (expr_string e) ^ "\n");
+		print_stmt (l+1) a;
+		for i = 1 to l do print_string " " done;
+		print_string "else\n";
+		print_stmt (l+1) b
+	| TSWhile(e, a) -> print_string ("while " ^ (expr_string e) ^ "\n");
+		print_stmt (l+1) a;
+	| TSFor(i, c, f, s) -> print_string 
+		("for " ^ 
+			(List.fold_left (fun x k -> x ^ ", " ^ (expr_string k)) "" i) ^ "; " ^
+			(match c with | None -> "" | Some(a) -> expr_string a) ^ "; " ^
+			(List.fold_left (fun x k -> x ^ ", " ^ (expr_string k)) "" f) ^ "\n");
+		print_stmt (l+1) s
+	| TSBlock(b) -> print_block l b
+	| TSReturn(None) -> print_string "return\n"
+	| TSReturn(Some k) -> print_string ("return " ^ (expr_string k) ^ "\n")
+	| TSDeclare((ty,b), i) -> let addr = (if b then "&" else "") in
+				  print_string (addr ^ i ^ " : " ^ (var_type_str ty) ^ "\n")
+	| TSDeclareAssignExpr((ty,b), i, e) -> let addr = (if b then "&" else "") in
+					  print_string (addr ^ i ^ " : " ^ (var_type_str ty) ^ " = " ^ (expr_string e) ^ "\n")
+	| TSDeclareAssignConstructor(t, i, c, a) -> () (*print_string
+		(i ^ " : " ^ (var_type_str t) ^ " = " ^ c ^ "(" ^
+							 (csl expr_string a) ^ ")\n")*)
+	| TSWriteCout(k) -> print_string ("std::cout" ^
+					     (List.fold_left (fun x k -> x ^ " << " ^ (match k with
+					       | TSEExpr e -> expr_string e
+					       | TSEStr("\n") -> "std::endl" 
+					       | TSEStr s -> "`" ^ s ^ "`")) "" k) ^ "\n")
+
+and print_block n b =
+  let prefix = String.make n ' ' in
+  print_string (prefix ^ "{\n");
+	List.iter
+		(fun s -> print_stmt (n+1) s)
+		b;
+	print_string (prefix ^ "}\n")
+
+let proto_str p =
+  (match p.tp_class with | Some c -> c ^ "::" | None -> "") ^ p.tp_name
+  ^ " (" ^ (csl 
+	      (fun ((ty,b), i) ->  let addr = (if b then "&" else "") in
+				   addr ^ i ^ " : " ^ (var_type_str ty)
+	      )
+	      p.tp_args)
+  ^ ") : " ^ (match p.tp_ret_type with | Some (ty,b) -> var_type_str ty | None -> "constructor")
+
+(*let print_class_decl c =
+	print_string ("class " ^ c.c_name ^ 
+		(match c.c_supers with | None -> "" | Some(s) -> " : " ^
+		(List.fold_left (fun x t -> x ^ " public " ^ t) "" s)) ^ " {\n");
+	List.iter (function
+		| CVar(t, i) -> print_string (" " ^ i ^ " : " ^ (var_type_str t) ^ "\n")
+		| CMethod(p) -> print_string (" " ^ (proto_str p) ^ "\n")
+		| CVirtualMethod(p) -> print_string (" virtual " ^ (proto_str p) ^ "\n")
+		) c.c_members;
+	print_string "}\n"*)
+
+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")
+		| TDFunction(p,b) -> print_string (proto_str p ^"\n");
+			print_block 0 b
+		| TDClass(c) -> () (* print_class_decl c  *)
+		| TDNothing -> ()
+		) 
+	  p
+
diff --git a/src/test.cpp b/src/test.cpp
new file mode 100644
index 0000000..81373c8
--- /dev/null
+++ b/src/test.cpp
@@ -0,0 +1 @@
+int m() { return 1==2 && 3==4 || !(5>=6); }
diff --git a/src/typing.ml b/src/typing.ml
new file mode 100644
index 0000000..1a5e566
--- /dev/null
+++ b/src/typing.ml
@@ -0,0 +1,393 @@
+open Ast
+
+exception Er_ident of ident (* i n'a pas de type, semble impossible au parser *)
+exception Er_tident_use
+exception Er_double_ref
+exception Er_ref_use
+exception Error of loc * string
+
+type typ =
+  | T_Int
+  | Typenull
+  | T_Void
+  | TClass of tident
+  | TPoint of typ
+
+type type_ref = typ * bool 
+(* type d'une variable, avec ref? *)
+
+type texpression = {
+  te_loc: loc;
+  te_desc: texpr_desc;
+  type_expr : typ*bool*bool; (* Type, référence?, valeur gauche? *)
+}
+
+and texpr_desc =
+  | TEInt of int
+  | TENull
+  | TEThis
+  | TEIdent of ident
+  | TEAssign of texpression * texpression
+  | TECallFun of ident * texpression list (* changé : te -> ident *)
+(* | TECallMeth of texpression * ident * texpression list *) (* changé : te -> ident *)
+  | TEUnary of unop * texpression
+  | TEBinary of texpression * binop * texpression
+  | TEMember of texpression * ident
+  | TENew of tident * texpression list
+
+type type_and_string =
+  | Typ of type_ref
+  | String
+
+
+type tstr_expression =
+	| TSEExpr of texpression
+	| TSEStr of string
+
+module Tstm = Map.Make(String) (* string -> env *)
+
+type stmt = mem Tstm.t
+
+and tstatement = {
+	ts_loc: loc;
+	ts_desc: ts_desc;
+	type_stm : stmt; }
+and ts_desc =
+	| TSEmpty
+	| TSExpr of texpression
+	| TSIf of texpression  * tstatement * tstatement
+	| TSWhile of texpression * tstatement
+	| TSFor of texpression list * texpression option * texpression list * tstatement
+	| TSBlock of tblock
+	| 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 *)
+(* Type of variable, variable name, constructor class name, constructor arguments *)
+	| TSWriteCout of tstr_expression list
+and tblock = tstatement list
+
+(*and fun_type = {
+  f_args : type_ref list; 
+  f_block : tblock; }
+peut être effacé *)
+
+and tproto = {
+	tp_loc : loc;
+	tp_name : ident;	
+	tp_class : tident option; (* p_class = none : standalone function *)
+	tp_ret_type : type_ref option; (* p_class = some and p_ret_type = none : constructor *)
+	tp_args : (type_ref * ident) list;
+}
+
+and mem = (* type d'une expression *)
+  | Var of type_ref
+  | Fun of tproto * tblock
+  | Env of stmt (* statement type *)
+
+module Tmem = Map.Make(String) (* string -> mem *)
+
+type tcls_mem =
+	| TCVar of var_type * ident
+	| TCMethod of tproto
+	| TCVirtualMethod of tproto
+
+type tcls = {
+	tc_name : tident;
+	tc_supers : tident list option;
+	tc_members : tcls_mem list;
+}
+
+type tdeclaration =
+	| TDGlobal of (type_ref * ident)
+	| TDFunction of (tproto * tblock)
+	| TDClass of tcls
+	| TDNothing
+
+type tprogram = tdeclaration list
+
+(* Quelques fonctions utiles : *)
+
+let find_v i env =
+  match Tmem.find i env with
+    | Var tr -> tr
+    | _ -> failwith "N'est pas une variable définie"
+
+let find_f i env =
+  match Tmem.find i env with
+    | Fun (p,t) -> (p,t)
+    | _ -> failwith "N'est pas une fonction définie"
+
+let same_type t1 t2 = (* types mem *)
+  let tr1 = (match t1 with
+    | Var (typ,_) -> typ
+    | _ -> failwith "Pas un type de variable"  ) in
+  let tr2 = (match t2 with
+   | Var (typ,_) -> typ
+    | _ -> failwith "Pas un type de variable"  ) in
+  tr1 = tr2
+
+(* true si bien formé *)
+let rec bf = function
+  | T_Int -> true
+  | TClass _ -> true
+  | TPoint t -> bf t
+  | _ -> false
+
+let num = function
+  | T_Int -> true
+  | Typenull -> true
+  | TPoint _ -> true
+  | _ -> false
+(* !! modifier si on peut pas être un type num peut pas aller
+avec une ref *)
+
+let build_type_or_ref vt = (* vt -> typ,bool = tr, true si ref *)
+  let rec see = function
+    | TPtr vt -> TPoint (see vt)
+    | TVoid -> T_Void
+    | TInt -> T_Int
+    | TRef _ -> raise Er_ref_use
+    | TIdent tid -> raise Er_tident_use
+  in
+  match vt with
+    | TRef (TRef vt) -> raise Er_double_ref (* ... *)
+    | TRef vt -> (see vt),true (* indique qu'il s'agit d'une ref *)
+    | vt -> (see vt),false
+
+(* -------------------------------------------- *)
+(* On passe aux choses sérieuses *)
+
+let rec type_expr env e = (* expression -> texpression *)
+  try 
+    let d,(ty,b1,b2) = compute_type env e in
+    { te_loc = e.e_loc; te_desc = d; type_expr = (ty,b1,b2) }
+  with | Er_ident i -> raise (Error (e.e_loc,("Type of variable "^i^" not declared")))
+    | _ -> raise (Error (e.e_loc,"Other"))
+
+and get_expr0 env e = (* expression -> texpression,(ty,b1,b2) *)
+  let te = type_expr env e in
+  (te,te.type_expr)
+
+and get_expr env e = (* expression -> texpression,(ty,b) *)
+  let te = type_expr env e in
+  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?) *)
+    | 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) *)
+	   assert (bf ty); (* règle champs p4 *)
+	   TEIdent i,(ty,b,true)
+       with Not_found -> raise (Er_ident i)
+      )
+    | EAssign (e1,e2) -> let te1,(ty1,_,b3) = get_expr0 env e1 in
+			 let te2,(ty2,_,_) = get_expr0 env e2 in
+			 assert (b3 = true);
+			 assert (num ty1); (* type num et ref compatibles ?*)
+			 (TEAssign (te1,te2) ),(ty1,false,false)
+    | EUnary (op,e) -> let te,(ty,b1,b2) = get_expr0 env e in
+		       (match op with
+			 | PreIncr | PostIncr | PreDecr | PostDecr ->
+			   assert (b2 = true);
+			   assert (ty = T_Int);
+			   TEUnary(op,te),(T_Int,b1,false)
+			 | Plus | Minus | Not ->
+			   assert (ty = T_Int);
+			   TEUnary(op,te),(T_Int,false,false)
+			 | Ref ->
+			   assert b2;
+			   TEUnary(op,te),(TPoint ty,false,false) (* verif *)
+			 | Deref ->
+			   let t = (match ty with
+			     | TPoint t -> t
+			     | _ -> failwith "On attend un type pointeur"   ) in
+			   TEUnary(op,te), (t,true,false)
+		       )
+    | EBinary (e1,op,e2) -> let te1,(ty1,_,b1) = get_expr0 env e1 in
+			    let te2,(ty2,_,b2) = get_expr0 env e2 in
+			    (match op with
+			      | Equal | NotEqual -> 
+				assert (ty1 = ty2);
+				assert (num ty1)
+			      | Lt | Le | Gt | Ge
+			      | Add | Sub | Mul | Div | Modulo
+			      | Land | Lor ->
+				assert (ty1 = T_Int);
+				assert (ty2 = T_Int)
+			    ); (* vérifs *)
+			    TEBinary(te1,op,te2),(T_Int,false,false)
+    | ECall (e,e_list) -> let name = (match e.e_desc with
+			    | EIdent i -> i
+			    | _ -> failwith "Not a function") in
+			  let tproto,tblock = find_f name env in (* chope la fonction *)
+			  let args = List.map (fun ((ty,_),_) -> ty) tproto.tp_args in (* pas adressage pris en compte *)
+			  let l = List.map (get_expr env) e_list in
+			  let tab = Array.of_list args in
+			  List.iteri 
+			    (fun j (te,(ty0,b)) -> 
+			      assert (ty0 = tab.(j) )   )
+			    l ;
+			  (* vérif ici pour adresse/valeur, ici on test seulement
+			     que ce sont les mêmes types, pas d'adressage de pris en compte *)
+			  let l_te = List.map fst l in 
+			  (* que les te de e_list*)
+			  let ty = match tproto.tp_ret_type with
+			    | None -> T_Void
+			    | Some (ty,b) -> ty in
+			  TECallFun(name,l_te),(ty,false,false)
+    | EMember _ -> TEInt 0, (T_Int,false,false)
+    | ENew _ -> TEInt 0, (T_Int,false,false)
+    | EThis -> TEInt 0, (T_Int,false,false)
+
+(* let compute_type_str_expr env e = (* str_expression -> (tse_str*)
+    match e.se_desc with
+    | SEExpr e0 -> let te,(t,b,_) = compute_type env {e_loc = e.se_loc; e_desc = e0} in
+		   (TSEExpr te),(Typ (t,b))
+    | SEStr s -> (TSEStr s),String
+
+let type_str_expr env e = (* str_expression -> tstr_expression *)
+  let t_str_te,ty = compute_type_str_expr env e in
+  { tse_loc = e.se_loc; tse_desc = t_str_te; type_str = ty }*)
+
+(* Statements *)
+
+let rec type_stm env s = 
+  let d, ty = compute_type_stm env s in
+  { ts_loc = s.s_loc; ts_desc = d; type_stm = ty }
+
+and get_stm env s = (* statement -> tstatement,tstm *)
+  let ts = type_stm env s in
+  (ts,ts.type_stm)
+
+and compute_type_stm env s = match s.s_desc with (* statement -> ts_desc,stm_type *)
+  | SEmpty -> TSEmpty,env
+  | SExpr e -> let te,(ty,_) = get_expr env e in (* verif ty est bien typé *)
+	       (TSExpr te) , env
+  | SBlock b -> build_block env b
+  | SReturn None -> (TSReturn None) , env
+  | SReturn (Some e0) ->  let te,(ty,_) = get_expr env e0 in
+			  TSReturn (Some te), env 
+  | SIf (e,s1,s2) ->  let te,(ty,_) = get_expr env e in
+		      let ts1,ty1 = get_stm env s1 in (* vérifs règle *)
+		      let ts2,ty2 = get_stm env s2 in
+		      assert (ty = T_Int);
+		      (TSIf (te,ts1,ts2)) , env		    
+  | SFor (el1,eopt,el3,s) -> let tel1 = List.map (type_expr env) el1 in (* et fait les vérifs pr e1 et e3 ? *)
+			     let tel3 = List.map (type_expr env) el3 in
+			     let teopt = (match eopt with
+			       | None -> None
+			       | Some e -> let te,(ty,_) = get_expr env e in
+					   assert (ty = T_Int);
+					   Some te) 
+			     in
+			     ignore( get_stm env s );  (* vérifie i *)
+			     let ts = type_stm env s in (* fait le truc d'avant aussi *)
+			     TSFor (tel1,teopt,tel3,ts) , env
+  (* traduire règles restantes du for*)
+  | SWhile(e,s) -> let ts,tys = get_stm env s in
+		   let te,(ty,_) = get_expr env e in
+		   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
+		      assert (bf ty);
+		      assert (not (Tmem.mem i env) );
+		      let env0 = Tmem.add i (Var (ty,b)) env in
+		      TSDeclare( (ty,b) ,i) , env0
+  | SDeclareAssignExpr(vt,i,e) -> let ty,b = build_type_or_ref vt in
+				  assert (bf ty);
+				  assert (not (Tmem.mem i env));
+				  let te,(tye,_) = get_expr env e in
+				 (* assert tye<ty;*)
+				  let env0 = Tstm.add i (Var (ty,b) ) env in
+				  TSDeclareAssignExpr( (ty,b) ,i,te) , env0
+  | SWriteCout(str_e_list) -> 
+    let args = 
+      List.map
+	(fun e -> match e.se_desc with
+	  | SEExpr e0 -> let te,(ty,_) = get_expr env {e_loc = e.se_loc; e_desc = e0} in 
+			 assert (ty = T_Int); TSEExpr te
+	  | SEStr s -> TSEStr(s) (* osef *)  
+	)
+	str_e_list 
+    in
+    TSWriteCout(args) , env
+  | SDeclareAssignConstructor(vt,i,ti,e_l) -> TSEmpty,env (* a faire *)
+		    
+and build_block env b = (* utilisé ds compute_type_stm et def_global_fun *)
+  let two_stms (env,l) s =
+    let ts,ty = get_stm env s in
+    (ty,(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
+
+and get_block env b =
+  match fst (build_block env b) with
+    | TSBlock tb -> tb
+    | _ -> failwith "Pas possible"
+
+(* Autres *)
+ 
+let get_fun env p b = (* p : proto   b : block -> name,Fun( ...)*)
+  let name = p.p_name in
+ (* let t = (match p.p_ret_type with
+    | Some ty -> ty
+    | None -> failwith "On traite les fonctions"  ) 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 n = List.length p.p_args in
+  let ids = Array.of_list( List.map snd p.p_args ) in (* juste les ident*)
+  for i = 0 to n-2 do
+    for j = i+1 to n-1 do
+      assert (String.compare ids.(i) ids.(j) = 0) (* compare 2 à 2 *)
+    done;
+  done;
+  List.iter (fun ((ty,_),_) -> assert( bf ty ) ) ty_args; 
+(* types st bf*)
+  let contexte = List.fold_left (* tr = (ty,ref?) *)
+    (fun envir (tr,i) -> Tmem.add i (Var tr) envir)
+    env
+    ty_args
+  in (* contexte ds l'instruction *)
+  let tb = get_block contexte b in (* vérif instructions typées*)
+  let tproto = { tp_loc = p.p_loc ; tp_name = name ; tp_class = None ;
+		 tp_ret_type = None ; tp_args = ty_args; }
+  in
+  name,tproto,tb
+
+let compute_decl env = function
+  | DGlobal(t,i) -> let tr = build_type_or_ref t in
+		    (TDGlobal(tr,i)) , (Tmem.add i (Var tr) env)
+  (* 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
+		       (TDFunction (tp,tb) ) , (Tmem.add name (Fun (tp,tb)) env)
+  | DClass c -> TDNothing,env
+
+let prog p =
+  let l = (
+    List.fold_left 
+      (fun list decl  -> let (td,env) = List.hd list in
+			 (compute_decl env decl)::list         )
+      [(TDNothing,Tmem.empty)]
+      p
+  ) in
+  List.map fst l
+
+(* raise (Error (e.e_loc,("Type of variable "^i^" not declared")))
+    | _ -> raise Error e.e_loc,("Other") *)
+
+
+
+