diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | src/main.ml | 25 | ||||
| -rw-r--r-- | src/pretty_typing.ml | 176 | ||||
| -rw-r--r-- | src/test.cpp | 1 | ||||
| -rw-r--r-- | src/typing.ml | 393 |
5 files changed, 590 insertions, 7 deletions
@@ -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") *) + + + + |