From 347cb3a11ddb3e4607d0f8b14bcd3a9fb900b86a Mon Sep 17 00:00:00 2001 From: Arnaud DABY-SEESARAM Date: Fri, 9 Dec 2022 23:18:13 +0100 Subject: [PATCH] =?UTF-8?q?[parser]=20ajout=20de=20fby=20(proposition=20al?= =?UTF-8?q?ternative)=20+=20type=20checker=20(sera=20factoris=C3=A9)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/lexer.mll | 1 + src/main.ml | 11 ++- src/parser.mly | 208 +++++++++++++++++++++++++++++++++++++++++-------- src/test.node | 2 - src/utils.ml | 2 + 5 files changed, 189 insertions(+), 35 deletions(-) diff --git a/src/lexer.mll b/src/lexer.mll index 5acc6ea..3fda6ca 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -32,6 +32,7 @@ ("pre", MO_pre); ("true", CONST_BOOL(true)); ("false", CONST_BOOL(false)); + ("fby", BO_fby); ]; fun s -> try Hashtbl.find h s with Not_found -> IDENT s diff --git a/src/main.ml b/src/main.ml index 0dd1951..438f40d 100644 --- a/src/main.ml +++ b/src/main.ml @@ -70,8 +70,15 @@ let _ = let res = Parser.main Lexer.token (Lexing.from_channel inchan) in close_in inchan; res end - with Lexer.Lexing_error s -> - exit_error (Format.sprintf "Code d'erreur:\n\t%s\n\n" s); exit 0 in + with + | Lexer.Lexing_error s -> + (exit_error (Format.sprintf "Code d'erreur:\n\t%s\n\n" s); exit 0) + | Utils.MyParsingError (s, l) -> + begin + Format.printf "Syntax error at %a: %s\n\n" + Pp.pp_loc l s; + exit 0 + end in if !ppast then Format.printf "%a" Pp.pp_ast ast else diff --git a/src/parser.mly b/src/parser.mly index fd62e82..5bc54e9 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1,6 +1,6 @@ %{ open Ast - exception MyParsingError of string + open Utils let current_location () = symbol_start_pos (), symbol_end_pos () @@ -12,14 +12,14 @@ match Hashtbl.find_opt defined_nodes n with | None -> raise (MyParsingError - ("The node "^n^" does not exist.")) + ("The node "^n^" does not exist.", current_location())) | Some node -> node let fetch_var (n: ident) : t_var = match Hashtbl.find_opt defined_vars n with | None -> raise (MyParsingError - ("The var "^n^" does not exist.")) + ("The var "^n^" does not exist.", current_location())) | Some var -> var let type_var (v: t_var) = @@ -44,7 +44,8 @@ match t1, t2 with | FTList lt1, FTList lt2 -> (FTList (lt1 @ lt2), e1@e2) | _ -> - raise (MyParsingError "This exception should not have been raised.")) + raise (MyParsingError ("This exception should not have been raised.", + current_location()))) let make_ident (v : t_var) : t_varlist = match v with @@ -57,7 +58,8 @@ | IVar _, (FTList tl, l) -> (FTList (FTBase TInt :: tl), v :: l) | BVar _, (FTList tl, l) -> (FTList (FTBase TBool :: tl), v :: l) | RVar _, (FTList tl, l) -> (FTList (FTBase TReal :: tl), v :: l) - | _ -> raise (MyParsingError "This exception should not have been raised.") + | _ -> raise (MyParsingError ("This exception should not have been raised.", + current_location())) %} %token EOF @@ -87,6 +89,7 @@ %token BO_div %token BO_mod %token BO_arrow +%token BO_fby %token CMP_le %token CMP_lt %token CMP_ge @@ -165,7 +168,7 @@ param: ( (FTList (List.map - (fun t -> FTBase t) (Utils.list_repeat (List.length idents) typ)), + (fun t -> FTBase t) (list_repeat (List.length idents) typ)), match typ with | TBool -> List.map (fun s -> Hashtbl.add defined_vars s (BVar s); BVar s) idents @@ -191,7 +194,8 @@ equation: let expr = $3 in if type_exp expr = t_patt then ((t_patt, patt), expr) - else raise (MyParsingError "The equation does not type check!") }; + else raise (MyParsingError ("The equation does not type check!", + current_location())) }; pattern: | IDENT @@ -209,31 +213,169 @@ expr: | LPAREN expr RPAREN { $2 } | IDENT { let v = fetch_var $1 in EVar (type_var v, v) } /* Unary operators */ - | MO_not expr { EMonOp (type_exp $2, MOp_not, $2) } + | MO_not expr + { let t = type_exp $2 in + if t = FTBase TBool + then EMonOp (t, MOp_not, $2) + else raise (MyParsingError ("You cannot negate a non-boolean \ + expression.", + current_location())) } | MO_pre expr { EMonOp (type_exp $2, MOp_pre, $2) } - | MINUS expr { EMonOp (type_exp $2, MOp_minus, $2) } - | PLUS expr { $2 } + | MINUS expr + { let t = type_exp $2 in + if t = FTBase TBool + then raise (MyParsingError ("You cannot take the opposite of a \ + boolean expression.", + current_location())) + else EMonOp (t, MOp_minus, $2) } + | PLUS expr + { let t = type_exp $2 in + if t = FTBase TBool + then raise (MyParsingError ("You cannot take the plus of a boolean \ + expression.", + current_location())) + else $2 } /* Binary operators */ - | expr PLUS expr { EBinOp (type_exp $1, BOp_add, $1, $3) } - | expr MINUS expr { EBinOp (type_exp $1, BOp_sub, $1, $3) } - | expr BO_mul expr { EBinOp (type_exp $1, BOp_mul, $1, $3) } - | expr BO_div expr { EBinOp (type_exp $1, BOp_div, $1, $3) } - | expr BO_mod expr { EBinOp (type_exp $1, BOp_mod, $1, $3) } - | expr BO_and expr { EBinOp (type_exp $1, BOp_and, $1, $3) } - | expr BO_or expr { EBinOp (type_exp $1, BOp_or, $1, $3) } - | expr BO_arrow expr { EBinOp (type_exp $1, BOp_arrow, $1, $3) } + | expr PLUS expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EBinOp (t1, BOp_add, $1, $3) + else raise (MyParsingError ("You should know better; addition hates \ + booleans", + current_location())) } + | expr MINUS expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EBinOp (t1, BOp_sub, $1, $3) + else raise (MyParsingError ("You should know better; subtraction \ + hates booleans", + current_location())) } + | expr BO_mul expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EBinOp (t1, BOp_mul, $1, $3) + else raise (MyParsingError ("You should know better; multiplication \ + hates booleans", + current_location())) } + | expr BO_div expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EBinOp (t1, BOp_div, $1, $3) + else raise (MyParsingError ("You should know better; division hates \ + booleans", + current_location())) } + | expr BO_mod expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EBinOp (t1, BOp_mod, $1, $3) + else raise (MyParsingError ("You should know better; modulo hates \ + booleans", + current_location())) } + | expr BO_and expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 = FTBase TBool + then EBinOp (t1, BOp_and, $1, $3) + else raise (MyParsingError ("You should know better; conjunction \ + hates numbers", + current_location())) } + | expr BO_or expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 = FTBase TBool + then EBinOp (t1, BOp_or, $1, $3) + else raise (MyParsingError ("You should know better; disjunction \ + hates numbers", + current_location())) } + | expr BO_arrow expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 + then EBinOp (type_exp $1, BOp_arrow, $1, $3) + else raise (MyParsingError ("The -> does not type-check", + current_location())) } + /* Binary operators, syntactic sugar */ + | expr BO_fby expr + { (* e fby e' ==> e -> (pre e') *) + let e = $1 in let e' = $3 in + let te = type_exp e in + if te = type_exp e' + then EBinOp (te, BOp_arrow, e, (EMonOp (te, MOp_pre, e'))) + else raise (MyParsingError ("The fby does not type-check!", + current_location())) } /* Comparison operators */ - | expr EQUAL expr { EComp (FTBase TBool, COp_eq, $1, $3) } - | expr CMP_neq expr { EComp (FTBase TBool, COp_neq, $1, $3) } - | expr CMP_le expr { EComp (FTBase TBool, COp_le, $1, $3) } - | expr CMP_lt expr { EComp (FTBase TBool, COp_lt, $1, $3) } - | expr CMP_ge expr { EComp (FTBase TBool, COp_ge, $1, $3) } - | expr CMP_gt expr { EComp (FTBase TBool, COp_gt, $1, $3) } + | expr EQUAL expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 + then EComp (FTBase TBool, COp_eq, $1, $3) + else raise (MyParsingError ("The equality does not type-check!", + current_location())) } + | expr CMP_neq expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 + then EComp (FTBase TBool, COp_neq, $1, $3) + else raise (MyParsingError ("The inequality does not type-check!", + current_location())) } + | expr CMP_le expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EComp (FTBase TBool, COp_le, $1, $3) + else raise (MyParsingError ("The comparison does not type-check!", + current_location())) } + | expr CMP_lt expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EComp (FTBase TBool, COp_lt, $1, $3) + else raise (MyParsingError ("The comparison does not type-check!", + current_location())) } + | expr CMP_ge expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EComp (FTBase TBool, COp_ge, $1, $3) + else raise (MyParsingError ("The comparison does not type-check!", + current_location())) } + | expr CMP_gt expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t1 = t2 && t1 <> FTBase TBool + then EComp (FTBase TBool, COp_gt, $1, $3) + else raise (MyParsingError ("The comparison does not type-check!", + current_location())) } /* Tertiary operators */ - | IF expr THEN expr ELSE expr { ETriOp (type_exp $4, TOp_if, $2, $4, $6) } - | TO_merge expr expr expr { ETriOp (type_exp $4, TOp_merge, $2, $3, $4) } + | IF expr THEN expr ELSE expr + { let e1 = $2 in let t1 = type_exp e1 in + let e2 = $4 in let t2 = type_exp e2 in + let e3 = $6 in let t3 = type_exp e3 in + if t2 = t3 && t1 = FTBase TBool + then ETriOp (t2, TOp_if, e1, e2, e3) + else raise (MyParsingError ("The if-then-else does not type-check!", + current_location())) } + | TO_merge expr expr expr + { let e1 = $2 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + let e3 = $4 in let t3 = type_exp e3 in + if t2 = t3 && t1 = FTBase TBool + then ETriOp (t2, TOp_merge, e1, e2, e3) + else raise (MyParsingError ("The if-then-else does not type-check!", + current_location())) } /* When is neither a binop (a * 'a -> 'a) or a comp ('a * 'a -> bool) */ - | expr WHEN expr { EWhen (type_exp $1, $1, $3) } + | expr WHEN expr + { let e1 = $1 in let t1 = type_exp e1 in + let e2 = $3 in let t2 = type_exp e2 in + if t2 = FTBase TBool + then EWhen (type_exp $1, $1, $3) + else raise (MyParsingError ("The when does not type-check!", + current_location())) } /* Constants */ | CONST_INT { EConst (FTBase TInt, CInt $1) } | CONST_BOOL { EConst (FTBase TBool, CBool $1) } @@ -249,8 +391,11 @@ expr: | FTArr (tin, t) -> if tin = type_exp args then EApp (t, fetch_node name, args) - else raise (MyParsingError "The application does not type check!") - | _ -> raise (MyParsingError "This exception should not have been raised from the dead.") + else raise (MyParsingError ("The application does not type check!", + current_location())) + | _ -> raise (MyParsingError ("This exception should not have been \ + raised from the dead.", + current_location())) } ; @@ -266,8 +411,9 @@ expr_comma_list: match e, le with | ETuple (FTList l1, t), ETuple (FTList l2, t') -> ETuple (FTList (l1@l2), t @ t') | _, ETuple (FTList lt, t') -> ETuple (FTList ((type_exp e)::lt), e :: t') - | _, _ -> raise (MyParsingError "This exception should not have been \ - raised.") } + | _, _ -> raise (MyParsingError ("This exception should not have been \ + raised.", + current_location())) } ; ident_comma_list: diff --git a/src/test.node b/src/test.node index 5e4bb31..81545bb 100644 --- a/src/test.node +++ b/src/test.node @@ -1,7 +1,5 @@ node diagonal_int (i: int) returns (o1, o2 : int); let - o1 = if true then i else 0; - o2 = i; (o1, o2) = (i, i); tel diff --git a/src/utils.ml b/src/utils.ml index f032a51..8a8defd 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -1,2 +1,4 @@ let rec list_repeat n elt = if n = 0 then [] else elt :: (list_repeat (n-1) elt) + +exception MyParsingError of (string * Ast.location)