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 *)
(* | TECallMethod 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 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") *)
