summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ast.ml5
-rw-r--r--src/main.ml6
-rw-r--r--src/parser.mly15
-rw-r--r--src/pretty.ml2
-rwxr-xr-xsrc/test.sh11
-rw-r--r--src/typing.ml200
6 files changed, 139 insertions, 100 deletions
diff --git a/src/ast.ml b/src/ast.ml
index d23b573..c204ff8 100644
--- a/src/ast.ml
+++ b/src/ast.ml
@@ -93,7 +93,10 @@ type cls = {
c_members : cls_mem list;
}
-type declaration =
+type declaration = {
+ d_loc : loc;
+ d_desc : decl_desc; }
+and decl_desc =
| DGlobal of (var_type * ident)
| DFunction of (proto * block)
| DClass of cls
diff --git a/src/main.ml b/src/main.ml
index 1a7d5b1..ca1134a 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -2,6 +2,7 @@ open Format
open Lexing
let parse_only = ref false
+let type_only = ref false
let dump = ref false
let dumpt = ref false
@@ -26,6 +27,7 @@ let localisation2 (pos1,pos2) =
let options = [
"--parse-only", Arg.Set parse_only, "Stops after parsing of the input file.";
+ "--type-only", Arg.Set type_only, "Stops after typechecking of the input file.";
"--dump", Arg.Set dump, "Dump the AST after parsing.";
"--dumpt", Arg.Set dumpt, "Dump the AST after typing."
]
@@ -53,6 +55,10 @@ let () =
if not !parse_only then begin
let t = Typing.prog p in
if !dumpt then Pretty_typing.print_prog t;
+
+ if not !type_only then begin
+ ()
+ end
end
with
| Lexer.Lexing_error s ->
diff --git a/src/parser.mly b/src/parser.mly
index a079886..5594430 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -71,19 +71,20 @@ prog:
declaration:
| p = proto
b = block
- { [ DFunction(p, b) ] }
+ { [ { d_loc = $startpos, $endpos; d_desc = DFunction(p, b) } ] }
| vars = typed_vars
SEMICOLON
- { List.map (fun k -> DGlobal(k)) vars }
+ { List.map (fun k -> { d_loc = $startpos, $endpos; d_desc = DGlobal(k) }) vars }
| n = cls
s = supers? LBRACE PUBLIC COLON
m = member* RBRACE SEMICOLON
{
- [ DClass({
- c_name = n;
- c_supers = s;
- c_members = List.flatten m;
- }) ]
+ [ { d_loc = $startpos, $endpos;
+ d_desc =DClass({
+ c_name = n;
+ c_supers = s;
+ c_members = List.flatten m;
+ }) } ]
}
;
diff --git a/src/pretty.ml b/src/pretty.ml
index e618bfa..4420ac1 100644
--- a/src/pretty.ml
+++ b/src/pretty.ml
@@ -152,7 +152,7 @@ let print_class_decl c =
print_string "}\n"
let print_prog p =
- List.iter (function
+ List.iter (fun k -> match k.d_desc with
| DGlobal(t, i) -> print_string ("decl " ^ i ^ " : " ^ (var_type_str t) ^ "\n")
| DFunction(p, b) -> print_string (proto_str p ^"\n");
print_block 0 b
diff --git a/src/test.sh b/src/test.sh
index 34a6997..525be77 100755
--- a/src/test.sh
+++ b/src/test.sh
@@ -36,7 +36,7 @@ for a in ../tests/exec/*.cpp; do
done;
echo "---"
-echo "Testing TYPING/GOOD for typing"
+echo "Testing TYPING/"
for a in ../tests/typing/good/*.cpp; do
if ./main.byte $a;
then echo "OK $a";
@@ -50,3 +50,12 @@ for a in ../tests/typing/bad/*.cpp; do
else echo "OK $a";
fi;
done;
+
+echo "---"
+echo "Testing EXEC/ only against typing"
+for a in ../tests/exec/*.cpp; do
+ if ./main.byte --type-only $a;
+ then echo "OK $a";
+ else echo "FAIL $a";
+ fi;
+done;
diff --git a/src/typing.ml b/src/typing.ml
index 620254d..0c47f72 100644
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -3,16 +3,17 @@ open Ast
(* Gestion des erreurs *)
exception LocError of loc * string
exception Error of string
-let er_ident i = raise (Error ("Unknown identifier " ^ i))
-let er_ident_loc i loc = raise (LocError (loc, "Unknown identifier " ^ i))
-let er_not_a_variable i = raise (Error ("Expected '"^i^"' to be a variable"))
-let er_not_a_function i = raise (Error ("Expected '"^i^"' to be a function"))
-let er_tident_use () = raise (Error ("Er_tident_use"))
-let er_double_ref () = raise (Error ("Er_double_ref"))
-let er_ref_use ()= raise (Error ("Er_ref_use"))
-let er_not_implemented () = raise (Error ("Not implemented"))
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 =
+ try f()
+ with
+ | Error(k) -> raise (LocError(loc, k))
+ | LocError(_, _) as e -> raise e
+ | Assert_failure (k, a, b) -> raise (LocError (loc, "Assertion failure : "^k^" at "^(string_of_int a)^":"^(string_of_int b)))
+ | Not_found -> raise (LocError (loc, "Not found"))
+ | Invalid_argument(k) -> raise (LocError (loc, "Invalid argument "^k))
+ | _ -> raise (LocError (loc, "Unexpected error"))
(* AST typés *)
@@ -78,11 +79,10 @@ and tproto = {
tp_args : (type_ref * ident) list;
}
-type mem = (* type d'une expression *)
+type decl_ident = (* type d'un identifieur *)
| Var of type_ref
| Fun of tproto * tblock
- | Env of stmt (* statement type *)
-and stmt = mem Smap.t (* string -> env *)
+and env = decl_ident Smap.t (* string -> decl_ident *)
type tcls_mem =
| TCVar of var_type * ident
@@ -108,21 +108,13 @@ type tprogram = tdeclaration list
let find_v i env =
match Smap.find i env with
| Var tr -> tr
- | _ -> er_not_a_variable i
+ | _ -> ty_error ("Not a variable : " ^ i)
let find_f i env =
match Smap.find i env with
| Fun (p,t) -> (p,t)
- | _ -> er_not_a_function i
+ | _ -> ty_error ("Not a function : " ^ i)
-let same_type t1 t2 = (* types mem *)
- let tr1 = (match t1 with
- | Var (typ,_) -> typ
- | _ -> er_not_a_variable "") in
- let tr2 = (match t2 with
- | Var (typ,_) -> typ
- | _ -> er_not_a_variable "") in
- tr1 = tr2
let rec bf = function (* true si bien formé *)
| T_Int -> true
@@ -143,25 +135,30 @@ let build_type_or_ref vt = (* vt -> typ,bool = tr, true si ref *)
| TPtr vt -> TPoint (see vt)
| TVoid -> T_Void
| TInt -> T_Int
- | TRef _ -> er_ref_use()
+ | TRef _ -> ty_error ("Unexpected reference type - no pionters on references allowed")
| TIdent tid -> TClass tid
in
match vt with
- | TRef (TRef vt) -> er_double_ref() (* ... *)
+ | TRef (TRef vt) -> ty_error ("Double references not allowed") (* ... *)
| 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
+
+
(* -------------------------------------------- *)
(* On passe aux choses sérieuses *)
let rec type_expr env e = (* expression -> texpression *)
- try
+ err_add_loc e.e_loc (fun () ->
let d,(ty,b1,b2) = compute_type env e in
- { te_loc = e.e_loc; te_desc = d; type_expr = (ty,b1,b2) }
- with
- | Error(k) -> raise (LocError(e.e_loc, k))
- | LocError(_, _) as e -> raise e
- | _ -> raise (LocError (e.e_loc,"Other error"))
+ { te_loc = e.e_loc; te_desc = d; type_expr = (ty,b1,b2) } )
and get_expr0 env e = (* expression -> texpression,(ty,b1,b2) *)
let te = type_expr env e in
@@ -182,12 +179,13 @@ and compute_type env e = match e.e_desc with (* expression -> te_desc,(typ,ref?,
(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 -> er_ident i
+ with Not_found -> ty_error ("Unknown identifier " ^ i)
)
- | EAssign (e1,e2) -> let te1,(ty1,_,b3) = get_expr0 env e1 in
+ | EAssign (e1,e2) -> let te1,(ty1,r3,b3) = get_expr0 env e1 in
let te2,(ty2,_,_) = get_expr0 env e2 in
- ty_assert (b3 = true) "Can only assign to lvalue";
+ 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";
(* type num et ref compatibles ?*)
(TEAssign (te1,te2) ),(ty1,false,false)
| EUnary (op,e) -> let te,(ty,b1,b2) = get_expr0 env e in
@@ -206,7 +204,7 @@ and compute_type env e = match e.e_desc with (* expression -> te_desc,(typ,ref?,
let t = (match ty with
| TPoint t -> t
| _ -> ty_error "Can only dereference pointer" ) in
- TEUnary(op,te), (t,true,false)
+ TEUnary(op,te), (t,false,true)
)
| EBinary (e1,op,e2) -> let te1,(ty1,_,b1) = get_expr0 env e1 in
let te2,(ty2,_,b2) = get_expr0 env e2 in
@@ -223,72 +221,89 @@ and compute_type env e = match e.e_desc with (* expression -> te_desc,(typ,ref?,
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
+ | _ -> ty_error "Calling something that is 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)) ->
- ty_assert (ty0 = tab.(j)) "Invalid type for function argument" )
- l ;
+ 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;
(* 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
+ let l_te = List.map fst args_values 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 ty,b = match tproto.tp_ret_type with
+ | None -> assert false (* no return type only happens for constructors, and
+ constructors cannot be called as functions *)
+ | 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"
(* Statements *)
-let rec type_stm env s =
- let d, ty = compute_type_stm env s in
- { ts_loc = s.s_loc; ts_desc = d }, ty
+let rec type_stm ret_type env s =
+ err_add_loc s.s_loc (fun () ->
+ let d, ty = compute_type_stm ret_type env s in
+ { ts_loc = s.s_loc; ts_desc = d }, ty)
-and compute_type_stm env s = match s.s_desc with (* statement -> ts_desc,stm_type *)
+and compute_type_stm ret_type 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
+ | SBlock b -> build_block ret_type env b
+ | SReturn None ->
+ let ty, ref = ret_type in
+ ty_assert (ty = T_Void) "Function must return non-void value";
+ (TSReturn None) , env
+ | 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";
+
TSReturn (Some te), env
| SIf (e,s1,s2) -> let te,(ty,_) = get_expr env e in
- let ts1,ty1 = type_stm env s1 in (* vérifs règle *)
- let ts2,ty2 = type_stm env s2 in
- assert (ty = T_Int);
+ let ts1,ty1 = type_stm ret_type env s1 in (* vérifs règle *)
+ let ts2,ty2 = type_stm ret_type env s2 in
+ ty_assert (ty = T_Int) "Condition in if statement must be integer";
(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);
+ ty_assert (ty = T_Int) "Condition in for statement must be integer";
Some te)
in
- ignore( type_stm env s ); (* vérifie i *)
- let ts, _ = type_stm env s in (* fait le truc d'avant aussi *)
+ ignore( type_stm ret_type env s ); (* vérifie i *)
+ let ts, _ = type_stm ret_type 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 = type_stm env s in
+ | SWhile(e,s) -> let ts,tys = type_stm ret_type env s in
let te,(ty,_) = get_expr env e in
+ ty_assert (ty = T_Int) "Condition in if statement must be integer";
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 (Smap.mem i env) );
+ 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
TSDeclare( (ty,b) ,i) , env0
| SDeclareAssignExpr(vt,i,e) -> let ty,b = build_type_or_ref vt in
- assert (bf ty);
- assert (not (Smap.mem i env));
- let te,(tye,_) = get_expr env e in
+ ty_assert (bf ty) "Malformed type";
+ ty_assert (not (Smap.mem i env)) "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
TSDeclareAssignExpr( (ty,b) ,i,te) , env0
@@ -297,7 +312,7 @@ and compute_type_stm env s = match s.s_desc with (* statement -> ts_desc,stm_typ
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
+ ty_assert (ty = T_Int) "Expected integer or string in cout<<"; TSEExpr te
| SEStr s -> TSEStr(s) (* osef *)
)
str_e_list
@@ -305,18 +320,18 @@ and compute_type_stm env s = match s.s_desc with (* statement -> ts_desc,stm_typ
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 *)
+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 env s in
+ let ts,ty = type_stm ret_type 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
+and get_block ret_type env b =
+ match fst (build_block ret_type env b) with
| TSBlock tb -> tb
- | _ -> failwith "Pas possible"
+ | _ -> assert false
(* Autres *)
@@ -330,33 +345,38 @@ let get_fun env p b = (* p : proto b : block -> name,Fun( ...)*)
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;
+ 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
in (* contexte ds l'instruction *)
- let tb = get_block contexte b in (* vérif instructions typées*)
+ 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 = None ; tp_args = ty_args; }
+ tp_ret_type = Some ret_type ; 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)) , (Smap.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) ) , (Smap.add name (Fun (tp,tb)) env)
- | DClass c -> er_not_implemented() (* TODO *)
+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)
+ (* 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 *)
+ )
let prog p =
let l = (
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 16:01:18 +0000