Benjamin_Loison/Synchronous_reactive_systems
1
0
Fork 0
Code Issues 7 Pull Requests Packages Projects Releases Wiki Activity

[parser] types of both side of equations are lists

Browse Source
This commit is contained in:
Arnaud DABY-SEESARAM 2022-12-10 17:14:54 +01:00
parent 45d64f6960
commit 5551237414
4 changed files with 79 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/ast.ml
View File

@ -35,10 +35,7 @@ type t_var =
| IVar of ident | IVar of ident
| RVar of ident | RVar of ident
type full_ty = type full_ty = base_ty list
| FTArr of full_ty * full_ty
| FTList of full_ty list
| FTBase of base_ty
type t_expression = type t_expression =
| EVar of full_ty * t_var | EVar of full_ty * t_var
@ -65,7 +62,8 @@ and t_node =
n_outputs: t_varlist; n_outputs: t_varlist;
n_local_vars: t_varlist; n_local_vars: t_varlist;
n_equations: t_eqlist; n_equations: t_eqlist;
n_type : full_ty; n_inputs_type : full_ty;
n_outputs_type : full_ty;
} }
type t_nodelist = t_node list type t_nodelist = t_node list

135
src/parser.mly
View File

@ -24,9 +24,9 @@
let type_var (v: t_var) = let type_var (v: t_var) =
match v with match v with
| IVar _ -> FTBase TInt | IVar _ -> [TInt]
| BVar _ -> FTBase TBool | BVar _ -> [TBool]
| RVar _ -> FTBase TReal | RVar _ -> [TReal]
let type_exp : t_expression -> full_ty = function let type_exp : t_expression -> full_ty = function
| EVar (full_ty , _) -> full_ty | EVar (full_ty , _) -> full_ty
@ -40,27 +40,19 @@
| ETuple (full_ty , _) -> full_ty | ETuple (full_ty , _) -> full_ty
| EApp (full_ty , _ , _) -> full_ty | EApp (full_ty , _ , _) -> full_ty
let concat_varlist (t1, e1) (t2, e2) = let concat_varlist (t1, e1) (t2, e2) = (t1 @ t2, e1 @ e2)
(
match t1, t2 with
| FTList lt1, FTList lt2 -> (FTList (lt1 @ lt2), e1@e2)
| _ ->
raise (MyParsingError ("This exception should not have been raised.",
current_location())))
let make_ident (v : t_var) : t_varlist = let make_ident (v : t_var) : t_varlist =
match v with match v with
| IVar _ -> (FTList [FTBase TInt ], [v]) | IVar _ -> [TInt ], [v]
| BVar _ -> (FTList [FTBase TBool], [v]) | BVar _ -> [TBool], [v]
| RVar _ -> (FTList [FTBase TReal], [v]) | RVar _ -> [TReal], [v]
let add_ident (v : t_var) (l: t_varlist) : t_varlist = let add_ident (v : t_var) (l: t_varlist) : t_varlist =
match v, l with match v, l with
| IVar _, (FTList tl, l) -> (FTList (FTBase TInt :: tl), v :: l) | IVar _, (tl, l) -> ((TInt :: tl), v :: l)
| BVar _, (FTList tl, l) -> (FTList (FTBase TBool :: tl), v :: l) | BVar _, (tl, l) -> ((TBool :: tl), v :: l)
| RVar _, (FTList tl, l) -> (FTList (FTBase TReal :: tl), v :: l) | RVar _, (tl, l) -> ((TReal :: tl), v :: l)
| _ -> raise (MyParsingError ("This exception should not have been raised.",
current_location()))
let monop_condition expr typ_constraint error_msg res = let monop_condition expr typ_constraint error_msg res =
if type_exp expr = typ_constraint if type_exp expr = typ_constraint
@ -74,50 +66,52 @@
let make_binop_nonbool e1 e2 op error_msg = let make_binop_nonbool e1 e2 op error_msg =
let t1 = type_exp e1 in let t2 = type_exp e2 in let t1 = type_exp e1 in let t2 = type_exp e2 in
match t1 with (** e1 and e2 should be nunmbers here.*)
| FTBase _ -> (** e1 and e2 should be nunmbers here.*) if list_chk t1 [[TInt]; [TReal]] && list_chk t2 [[TInt]; [TReal]]
if t1 = t2 && t1 <> FTBase TBool then
then EBinOp (t1, op, e1, e2) begin
else raise (MyParsingError (error_msg, current_location())) if t1 = t2
| _ -> raise (MyParsingError (error_msg, current_location())) then EBinOp (t1, op, e1, e2)
else raise (MyParsingError (error_msg, current_location()))
end
else raise (MyParsingError (error_msg, current_location()))
let make_binop_bool e1 e2 op error_msg = let make_binop_bool e1 e2 op error_msg =
let t1 = type_exp e1 in let t2 = type_exp e2 in let t1 = type_exp e1 in let t2 = type_exp e2 in
if t1 = t2 && t1 = FTBase TBool if t1 = t2 && t1 = [TBool]
then EBinOp (t1, op, e1, e2) then EBinOp (t1, op, e1, e2)
else raise (MyParsingError (error_msg, current_location())) else raise (MyParsingError (error_msg, current_location()))
let make_comp e1 e2 op error_msg = let make_comp e1 e2 op error_msg =
let t1 = type_exp e1 in let t2 = type_exp e2 in let t1 = type_exp e1 in let t2 = type_exp e2 in
if t1 = t2 (** e1 and e2 should not be tuples *)
then EComp (FTBase TBool, op, e1, e2) if t1 = t2 && List.length t1 = 1
then EComp ([TBool], op, e1, e2)
else raise (MyParsingError (error_msg, current_location())) else raise (MyParsingError (error_msg, current_location()))
let make_comp_nonbool e1 e2 op error_msg = let make_comp_nonbool e1 e2 op error_msg =
let t1 = type_exp e1 in let t2 = type_exp e2 in let t1 = type_exp e1 in let t2 = type_exp e2 in
match t1 with (** e1 and e2 should be nunmbers here.*)
| FTBase _ -> (** e1 and e2 should be numbers here. *) if list_chk t1 [[TInt]; [TReal]] && list_chk t2 [[TInt]; [TReal]]
if t1 = t2 && t1 <> FTBase TBool then
then EComp (FTBase TBool, op, e1, e2) begin
else raise (MyParsingError (error_msg, current_location())) if t1 = t2
| _ -> raise (MyParsingError (error_msg, current_location())) then EComp ([TBool], op, e1, e2)
else raise (MyParsingError (error_msg, current_location()))
end
else raise (MyParsingError (error_msg, current_location()))
let make_tertiary e1 e2 e3 op error_msg = let make_tertiary e1 e2 e3 op error_msg =
let t1 = type_exp e1 in let t2 = type_exp e2 in let t3 = type_exp e3 in let t1 = type_exp e1 in let t2 = type_exp e2 in let t3 = type_exp e3 in
if t2 = t3 && t1 = FTBase TBool if t2 = t3 && t1 = [TBool]
then ETriOp (t2, op, e1, e2, e3) then ETriOp (t2, op, e1, e2, e3)
else raise (MyParsingError (error_msg, current_location())) else raise (MyParsingError (error_msg, current_location()))
let rec debug_type_pp fmt = function let rec debug_type_pp fmt = function
| FTBase TBool -> Format.fprintf fmt "bool" | [] -> ()
| FTBase TReal -> Format.fprintf fmt "real" | TInt :: t -> Format.fprintf fmt "int %a" debug_type_pp t
| FTBase TInt -> Format.fprintf fmt "int" | TBool :: t -> Format.fprintf fmt "bool %a" debug_type_pp t
| FTArr (t1, t2) -> Format.fprintf fmt "( %a -> %a )" | TReal :: t -> Format.fprintf fmt "real %a" debug_type_pp t
debug_type_pp t1 debug_type_pp t2
| FTList [] -> ()
| FTList (h :: []) -> Format.fprintf fmt "l%a" debug_type_pp h
| FTList (h :: h' :: t) ->
Format.fprintf fmt "l%a; %a" debug_type_pp h debug_type_pp (FTList (h' :: t))
let debug_type = let debug_type =
Format.printf "Type: %a\n" debug_type_pp Format.printf "Type: %a\n" debug_type_pp
@ -201,7 +195,8 @@ node_content:
n_outputs = (t_out, e_out); n_outputs = (t_out, e_out);
n_local_vars = $10; n_local_vars = $10;
n_equations = $12; n_equations = $12;
n_type = FTArr (t_in, t_out); } in n_inputs_type = t_in;
n_outputs_type = t_out; } in
Hashtbl.add defined_nodes node_name n; n }; Hashtbl.add defined_nodes node_name n; n };
OPTIONAL_SEMICOL: OPTIONAL_SEMICOL:
@ -210,14 +205,14 @@ OPTIONAL_SEMICOL:
; ;
in_params: in_params:
| /* empty */ { (FTList [], []) } | /* empty */ { ([], []) }
| param_list { $1 } | param_list { $1 }
; ;
out_params: param_list { $1 } ; out_params: param_list { $1 } ;
local_params: local_params:
| /* empty */ { (FTList [], []) } | /* empty */ { ([], []) }
| VAR param_list_semicol { $2 } | VAR param_list_semicol { $2 }
; ;
@ -234,17 +229,14 @@ param:
ident_comma_list COLON TYP ident_comma_list COLON TYP
{ let typ = $3 in { let typ = $3 in
let idents = $1 in let idents = $1 in
( (list_repeat (List.length idents) typ,
(FTList
(List.map
(fun t -> FTBase t) (list_repeat (List.length idents) typ)),
match typ with match typ with
| TBool -> | TBool ->
List.map (fun s -> Hashtbl.add defined_vars s (BVar s); BVar s) idents List.map (fun s -> Hashtbl.add defined_vars s (BVar s); BVar s) idents
| TReal -> | TReal ->
List.map (fun s -> Hashtbl.add defined_vars s (RVar s); RVar s) idents List.map (fun s -> Hashtbl.add defined_vars s (RVar s); RVar s) idents
| TInt -> | TInt ->
List.map (fun s -> Hashtbl.add defined_vars s (IVar s); IVar s) idents)) } List.map (fun s -> Hashtbl.add defined_vars s (IVar s); IVar s) idents) }
; ;
ident_comma_list: ident_comma_list:
@ -261,9 +253,7 @@ equation:
pattern EQUAL expr pattern EQUAL expr
{ let (t_patt, patt) = $1 in { let (t_patt, patt) = $1 in
let expr = $3 in let texpr = type_exp expr in let expr = $3 in let texpr = type_exp expr in
if (match texpr with if t_patt = texpr
| FTList _ -> texpr = t_patt
| _ -> FTList [texpr] = t_patt)
then ((t_patt, patt), expr) then ((t_patt, patt), expr)
else (debug_type t_patt; debug_type (type_exp expr); else (debug_type t_patt; debug_type (type_exp expr);
raise (MyParsingError ("The equation does not type check!", raise (MyParsingError ("The equation does not type check!",
@ -271,9 +261,7 @@ equation:
pattern: pattern:
| IDENT | IDENT
{ let v = fetch_var $1 in { let v = fetch_var $1 in (type_var v, [v]) }
(FTList [type_var v], [v])
}
| LPAREN ident_comma_list_patt RPAREN { $2 }; | LPAREN ident_comma_list_patt RPAREN { $2 };
ident_comma_list_patt: ident_comma_list_patt:
@ -286,16 +274,16 @@ expr:
| IDENT { let v = fetch_var $1 in EVar (type_var v, v) } | IDENT { let v = fetch_var $1 in EVar (type_var v, v) }
/* Unary operators */ /* Unary operators */
| MO_not expr | MO_not expr
{ monop_condition $2 (FTBase TBool) { monop_condition $2 [TBool]
"You cannot negate a non-boolean expression." "You cannot negate a non-boolean expression."
(EMonOp (type_exp $2, MOp_not, $2)) } (EMonOp (type_exp $2, MOp_not, $2)) }
| MO_pre expr { EMonOp (type_exp $2, MOp_pre, $2) } | MO_pre expr { EMonOp (type_exp $2, MOp_pre, $2) }
| MINUS expr | MINUS expr
{ monop_neg_condition $2 (FTBase TBool) { monop_neg_condition $2 [TBool]
"You cannot take the opposite of a boolean expression." "You cannot take the opposite of a boolean expression."
(EMonOp (type_exp $2, MOp_minus, $2)) } (EMonOp (type_exp $2, MOp_minus, $2)) }
| PLUS expr | PLUS expr
{ monop_neg_condition $2 (FTBase TBool) { monop_neg_condition $2 [TBool]
"You cannot take the plus of a boolean expression." $2 } "You cannot take the plus of a boolean expression." $2 }
/* Binary operators */ /* Binary operators */
| expr PLUS expr | expr PLUS expr
@ -357,21 +345,21 @@ expr:
| expr WHEN expr | expr WHEN expr
{ let e1 = $1 in let t1 = type_exp e1 in { let e1 = $1 in let t1 = type_exp e1 in
let e2 = $3 in let t2 = type_exp e2 in let e2 = $3 in let t2 = type_exp e2 in
if t2 = FTBase TBool if t2 = [TBool]
then EWhen (type_exp $1, $1, $3) then EWhen (type_exp $1, $1, $3)
else raise (MyParsingError ("The when does not type-check!", else raise (MyParsingError ("The when does not type-check!",
current_location())) } current_location())) }
| expr RESET expr | expr RESET expr
{ let e1 = $1 in let t1 = type_exp e1 in { let e1 = $1 in let t1 = type_exp e1 in
let e2 = $3 in let t2 = type_exp e2 in let e2 = $3 in let t2 = type_exp e2 in
if t2 = FTBase TBool if t2 = [TBool]
then EReset (type_exp $1, $1, $3) then EReset (type_exp $1, $1, $3)
else raise (MyParsingError ("The reset does not type-check!", else raise (MyParsingError ("The reset does not type-check!",
current_location())) } current_location())) }
/* Constants */ /* Constants */
| CONST_INT { EConst (FTBase TInt, CInt $1) } | CONST_INT { EConst ([TInt], CInt $1) }
| CONST_BOOL { EConst (FTBase TBool, CBool $1) } | CONST_BOOL { EConst ([TBool], CBool $1) }
| CONST_REAL { EConst (FTBase TReal, CReal $1) } | CONST_REAL { EConst ([TReal], CReal $1) }
/* Tuples */ /* Tuples */
| LPAREN expr_comma_list RPAREN { $2 } | LPAREN expr_comma_list RPAREN { $2 }
/* Applications */ /* Applications */
@ -379,14 +367,9 @@ expr:
{ let name = $1 in { let name = $1 in
let node = fetch_node name in let node = fetch_node name in
let args = $3 in let args = $3 in
match node.n_type with if type_exp args = node.n_inputs_type
| FTArr (tin, t) -> then EApp (node.n_outputs_type, fetch_node name, args)
if tin = type_exp args else raise (MyParsingError ("The application does not type check!",
then EApp (t, fetch_node name, args)
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())) current_location()))
} }
; ;
@ -396,13 +379,13 @@ expr_comma_list:
{ let e = $1 in { let e = $1 in
match e with match e with
| ETuple _ -> e | ETuple _ -> e
| _ -> ETuple (FTList [type_exp e], [e]) } | _ -> ETuple (type_exp e, [e]) }
| expr COMMA expr_comma_list | expr COMMA expr_comma_list
{ let e = $1 in { let e = $1 in
let le = $3 in let le = $3 in
match e, le with match e, le with
| ETuple (FTList l1, t), ETuple (FTList l2, t') -> ETuple (FTList (l1@l2), t @ t') | ETuple (l1, t), ETuple (l2, t') -> ETuple (l1 @ l2, t @ t')
| _, ETuple (FTList lt, t') -> ETuple (FTList ((type_exp e)::lt), e :: t') | _, ETuple (lt, t') -> ETuple (((type_exp e) @ lt), e :: t')
| _, _ -> raise (MyParsingError ("This exception should not have been \ | _, _ -> raise (MyParsingError ("This exception should not have been \
raised.", raised.",
current_location())) } current_location())) }

26
src/pp.ml
View File

@ -8,16 +8,16 @@ let pp_loc fmt (start, stop) =
stop.pos_lnum stop.pos_cnum) stop.pos_lnum stop.pos_cnum)
let rec pp_varlist fmt : t_varlist -> unit = function let rec pp_varlist fmt : t_varlist -> unit = function
| (FTList [], []) -> () | ([], []) -> ()
| (FTList (FTBase TInt :: _), IVar h :: []) -> Format.fprintf fmt "%s: int" h | ([TInt] , IVar h :: []) -> Format.fprintf fmt "%s: int" h
| (FTList (FTBase TReal :: _), RVar h :: []) -> Format.fprintf fmt "%s: real" h | ([TReal], RVar h :: []) -> Format.fprintf fmt "%s: real" h
| (FTList (FTBase TBool :: _), BVar h :: []) -> Format.fprintf fmt "%s: bool" h | ([TBool], BVar h :: []) -> Format.fprintf fmt "%s: bool" h
| (FTList (FTBase TInt :: tl), (IVar h) :: h' :: l) -> | (TInt :: tl, IVar h :: h' :: l) ->
Format.fprintf fmt "%s: int, %a" h pp_varlist (FTList tl, (h' :: l)) Format.fprintf fmt "%s: int, %a" h pp_varlist (tl, h' :: l)
| (FTList (FTBase TBool :: tl), (BVar h) :: h' :: l) -> | (TBool :: tl, BVar h :: h' :: l) ->
Format.fprintf fmt "%s: bool, %a" h pp_varlist (FTList tl, (h' :: l)) Format.fprintf fmt "%s: bool, %a" h pp_varlist (tl, h' :: l)
| (FTList (FTBase TReal :: tl), (RVar h) :: h' :: l) -> | (TReal :: tl, RVar h :: h' :: l) ->
Format.fprintf fmt "%s: real, %a" h pp_varlist (FTList tl, (h' :: l)) Format.fprintf fmt "%s: real, %a" h pp_varlist (tl, h' :: l)
| _ -> raise (MyTypeError "This exception should not have beed be raised.") | _ -> raise (MyTypeError "This exception should not have beed be raised.")
let pp_expression = let pp_expression =
@ -25,11 +25,11 @@ let pp_expression =
let rec pp_expression_aux prefix fmt expression = let rec pp_expression_aux prefix fmt expression =
let rec pp_expression_list prefix fmt exprs = let rec pp_expression_list prefix fmt exprs =
match exprs with match exprs with
| ETuple(FTList [], []) -> () | ETuple([], []) -> ()
| ETuple (FTList (_ :: tt), expr :: exprs) -> | ETuple (_ :: tt, expr :: exprs) ->
Format.fprintf fmt "%a%a" Format.fprintf fmt "%a%a"
(pp_expression_aux (prefix^" |> ")) expr (pp_expression_aux (prefix^" |> ")) expr
(pp_expression_list prefix) (ETuple (FTList tt, exprs)) (pp_expression_list prefix) (ETuple (tt, exprs))
| _ -> raise (MyTypeError "This exception should not have been raised.") | _ -> raise (MyTypeError "This exception should not have been raised.")
in in
match expression with match expression with

4
src/utils.ml
View File

@ -1,4 +1,8 @@
let rec list_repeat n elt = let rec list_repeat n elt =
if n = 0 then [] else elt :: (list_repeat (n-1) elt) if n = 0 then [] else elt :: (list_repeat (n-1) elt)
let rec list_chk v = function
| [] -> false
| h :: t -> if h = v then true else list_chk v t
exception MyParsingError of (string * Ast.location) exception MyParsingError of (string * Ast.location)