diff --git a/src/passes/1-parser/pascaligo.ml b/src/passes/1-parser/pascaligo.ml index 4858fd0a4..2cf59bb3b 100644 --- a/src/passes/1-parser/pascaligo.ml +++ b/src/passes/1-parser/pascaligo.ml @@ -28,6 +28,15 @@ module Errors = struct ] in error ~data title message + let non_linear_pattern Region.{value; region} = + let title () = Printf.sprintf "repeated variable \"%s\" in this pattern" value in + let message () = "" in + let data = [ + ("location", + fun () -> Format.asprintf "%a" Location.pp_lift @@ region) + ] in + error ~data title message + let duplicate_parameter Region.{value; region} = let title () = Printf.sprintf "duplicate parameter \"%s\"" value in let message () = "" in @@ -118,7 +127,9 @@ let parse (parser: 'a parser) source lexbuf = try ok (parser read lexbuf) with - SyntaxError.Error (Duplicate_parameter name) -> + SyntaxError.Error (Non_linear_pattern var) -> + fail @@ (non_linear_pattern var) + | SyntaxError.Error (Duplicate_parameter name) -> fail @@ (duplicate_parameter name) | SyntaxError.Error (Duplicate_variant name) -> fail @@ (duplicate_variant name) diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml index 9aca3eaf3..6dbf62137 100644 --- a/src/passes/1-parser/pascaligo/AST.ml +++ b/src/passes/1-parser/pascaligo/AST.ml @@ -2,7 +2,7 @@ (* To disable warning about multiply-defined record labels. *) -[@@@warning "-30-42"] +[@@@warning "-30-40-42"] (* Utilities *) @@ -21,22 +21,6 @@ open Utils type 'a reg = 'a Region.reg -let rec last to_region = function - [] -> Region.ghost -| [x] -> to_region x -| _::t -> last to_region t - -let nseq_to_region to_region (hd,tl) = - Region.cover (to_region hd) (last to_region tl) - -let nsepseq_to_region to_region (hd,tl) = - let reg (_, item) = to_region item in - Region.cover (to_region hd) (last reg tl) - -let sepseq_to_region to_region = function - None -> Region.ghost -| Some seq -> nsepseq_to_region to_region seq - (* Keywords of LIGO *) type keyword = Region.t @@ -85,32 +69,32 @@ type c_Unit = Region.t (* Symbols *) -type semi = Region.t -type comma = Region.t -type lpar = Region.t -type rpar = Region.t -type lbrace = Region.t -type rbrace = Region.t -type lbracket = Region.t -type rbracket = Region.t -type cons = Region.t -type vbar = Region.t -type arrow = Region.t -type assign = Region.t -type equal = Region.t -type colon = Region.t -type lt = Region.t -type leq = Region.t -type gt = Region.t -type geq = Region.t -type neq = Region.t -type plus = Region.t -type minus = Region.t -type slash = Region.t -type times = Region.t -type dot = Region.t -type wild = Region.t -type cat = Region.t +type semi = Region.t (* ";" *) +type comma = Region.t (* "," *) +type lpar = Region.t (* "(" *) +type rpar = Region.t (* ")" *) +type lbrace = Region.t (* "{" *) +type rbrace = Region.t (* "}" *) +type lbracket = Region.t (* "[" *) +type rbracket = Region.t (* "]" *) +type cons = Region.t (* "#" *) +type vbar = Region.t (* "|" *) +type arrow = Region.t (* "->" *) +type assign = Region.t (* ":=" *) +type equal = Region.t (* "=" *) +type colon = Region.t (* ":" *) +type lt = Region.t (* "<" *) +type leq = Region.t (* "<=" *) +type gt = Region.t (* ">" *) +type geq = Region.t (* ">=" *) +type neq = Region.t (* "=/=" *) +type plus = Region.t (* "+" *) +type minus = Region.t (* "-" *) +type slash = Region.t (* "/" *) +type times = Region.t (* "*" *) +type dot = Region.t (* "." *) +type wild = Region.t (* "_" *) +type cat = Region.t (* "^" *) (* Virtual tokens *) @@ -613,9 +597,24 @@ and list_pattern = | PParCons of (pattern * cons * pattern) par reg | PCons of (pattern, cons) nsepseq reg + (* Projecting regions *) -open! Region +let rec last to_region = function + [] -> Region.ghost +| [x] -> to_region x +| _::t -> last to_region t + +let nseq_to_region to_region (hd,tl) = + Region.cover (to_region hd) (last to_region tl) + +let nsepseq_to_region to_region (hd,tl) = + let reg (_, item) = to_region item in + Region.cover (to_region hd) (last reg tl) + +let sepseq_to_region to_region = function + None -> Region.ghost +| Some seq -> nsepseq_to_region to_region seq let type_expr_to_region = function TProd {region; _} @@ -760,49 +759,4 @@ let rhs_to_region = expr_to_region let selection_to_region = function FieldName {region; _} - | Component {region; _} -> region - -(* Extracting variables from patterns *) - -module Ord = - struct - type t = string Region.reg - let compare v1 v2 = - compare v1.value v2.value - end - -module VSet = Set.Make (Ord) - -let rec vars_of_pattern env = function - PConstr p -> vars_of_pconstr env p -| PVar v -> VSet.add v env -| PWild _ | PInt _ | PNat _ | PBytes _ | PString _ -> env -| PList l -> vars_of_plist env l -| PTuple t -> vars_of_ptuple env t.value - -and vars_of_pconstr env = function - PUnit _ | PFalse _ | PTrue _ | PNone _ -> env -| PSomeApp {value=_, {value={inside; _};_}; _} -> - vars_of_pattern env inside -| PConstrApp {value=_, Some tuple; _} -> - vars_of_ptuple env tuple.value -| PConstrApp {value=_,None; _} -> env - -and vars_of_plist env = function - PListComp {value; _} -> - vars_of_pinj env value -| PNil _ -> - env -| PParCons {value={inside; _}; _} -> - let head, _, tail = inside in - vars_of_pattern (vars_of_pattern env head) tail -| PCons {value; _} -> - Utils.nsepseq_foldl vars_of_pattern env value - -and vars_of_pinj env inj = - Utils.sepseq_foldl vars_of_pattern env inj.elements - -and vars_of_ptuple env {inside; _} = - Utils.nsepseq_foldl vars_of_pattern env inside - -let vars_of_pattern = vars_of_pattern VSet.empty +| Component {region; _} -> region diff --git a/src/passes/1-parser/pascaligo/AST.mli b/src/passes/1-parser/pascaligo/AST.mli deleted file mode 100644 index 70620a880..000000000 --- a/src/passes/1-parser/pascaligo/AST.mli +++ /dev/null @@ -1,623 +0,0 @@ -(* Abstract Syntax Tree (AST) for Pascaligo *) - -[@@@warning "-30"] - -open Utils - -(* Regions - - The AST carries all the regions where tokens have been found by the - lexer, plus additional regions corresponding to whole subtrees - (like entire expressions, patterns etc.). These regions are needed - for error reporting and source-to-source transformations. To make - these pervasive regions more legible, we define singleton types for - the symbols, keywords etc. with suggestive names like "kwd_and" - denoting the _region_ of the occurrence of the keyword "and". -*) - -type 'a reg = 'a Region.reg - -val nseq_to_region : ('a -> Region.t) -> 'a nseq -> Region.t -val nsepseq_to_region : ('a -> Region.t) -> ('a,'sep) nsepseq -> Region.t -val sepseq_to_region : ('a -> Region.t) -> ('a,'sep) sepseq -> Region.t - -(* Keywords of LIGO *) - -type keyword = Region.t -type kwd_and = Region.t -type kwd_begin = Region.t -type kwd_block = Region.t -type kwd_case = Region.t -type kwd_const = Region.t -type kwd_contains = Region.t -type kwd_down = Region.t -type kwd_else = Region.t -type kwd_end = Region.t -type kwd_for = Region.t -type kwd_from = Region.t -type kwd_function = Region.t -type kwd_if = Region.t -type kwd_in = Region.t -type kwd_is = Region.t -type kwd_list = Region.t -type kwd_map = Region.t -type kwd_mod = Region.t -type kwd_nil = Region.t -type kwd_not = Region.t -type kwd_of = Region.t -type kwd_or = Region.t -type kwd_patch = Region.t -type kwd_record = Region.t -type kwd_remove = Region.t -type kwd_set = Region.t -type kwd_skip = Region.t -type kwd_step = Region.t -type kwd_then = Region.t -type kwd_to = Region.t -type kwd_type = Region.t -type kwd_var = Region.t -type kwd_while = Region.t -type kwd_with = Region.t - -(* Data constructors *) - -type c_False = Region.t -type c_None = Region.t -type c_Some = Region.t -type c_True = Region.t -type c_Unit = Region.t - -(* Symbols *) - -type semi = Region.t (* ";" *) -type comma = Region.t (* "," *) -type lpar = Region.t (* "(" *) -type rpar = Region.t (* ")" *) -type lbrace = Region.t (* "{" *) -type rbrace = Region.t (* "}" *) -type lbracket = Region.t (* "[" *) -type rbracket = Region.t (* "]" *) -type cons = Region.t (* "#" *) -type vbar = Region.t (* "|" *) -type arrow = Region.t (* "->" *) -type assign = Region.t (* ":=" *) -type equal = Region.t (* "=" *) -type colon = Region.t (* ":" *) -type lt = Region.t (* "<" *) -type leq = Region.t (* "<=" *) -type gt = Region.t (* ">" *) -type geq = Region.t (* ">=" *) -type neq = Region.t (* "=/=" *) -type plus = Region.t (* "+" *) -type minus = Region.t (* "-" *) -type slash = Region.t (* "/" *) -type times = Region.t (* "*" *) -type dot = Region.t (* "." *) -type wild = Region.t (* "_" *) -type cat = Region.t (* "^" *) - -(* Virtual tokens *) - -type eof = Region.t - -(* Literals *) - -type variable = string reg -type fun_name = string reg -type type_name = string reg -type field_name = string reg -type map_name = string reg -type set_name = string reg -type constr = string reg - -(* Parentheses *) - -type 'a par = { - lpar : lpar; - inside : 'a; - rpar : rpar -} - -(* Brackets compounds *) - -type 'a brackets = { - lbracket : lbracket; - inside : 'a; - rbracket : rbracket -} - -(* Braced compounds *) - -type 'a braces = { - lbrace : lbrace; - inside : 'a; - rbrace : rbrace -} - -(** The Abstract Syntax Tree - -The AST mirrors the contents of Parser.mly, which defines a tree of parsing -productions that are used to make a syntax tree from a given program input. - -This file defines the concrete AST for PascaLIGO, which is used to associate -regions of the source code text with the contents of the syntax tree. - -*) -type t = { - decl : declaration nseq; - eof : eof -} - -and ast = t - -and declaration = - TypeDecl of type_decl reg -| ConstDecl of const_decl reg -| FunDecl of fun_decl reg - -and const_decl = { - kwd_const : kwd_const; - name : variable; - colon : colon; - const_type : type_expr; - equal : equal; - init : expr; - terminator : semi option -} - -(* Type declarations *) - -and type_decl = { - kwd_type : kwd_type; - name : type_name; - kwd_is : kwd_is; - type_expr : type_expr; - terminator : semi option -} - -and type_expr = - TProd of cartesian -| TSum of (variant reg, vbar) nsepseq reg -| TRecord of field_decl reg ne_injection reg -| TApp of (type_name * type_tuple) reg -| TFun of (type_expr * arrow * type_expr) reg -| TPar of type_expr par reg -| TVar of variable - -and cartesian = (type_expr, times) nsepseq reg - -and variant = { - constr : constr; - arg : (kwd_of * type_expr) option -} - -and field_decl = { - field_name : field_name; - colon : colon; - field_type : type_expr -} - -and type_tuple = (type_expr, comma) nsepseq par reg - -(* Function declarations *) - -and fun_expr = { - kwd_function : kwd_function; - name : variable option; - param : parameters; - colon : colon; - ret_type : type_expr; - kwd_is : kwd_is; - block_with : (block reg * kwd_with) option; - return : expr -} - -and fun_decl = { - fun_expr : fun_expr reg; - terminator : semi option -} - -and parameters = (param_decl, semi) nsepseq par reg - -and param_decl = - ParamConst of param_const reg -| ParamVar of param_var reg - -and param_const = { - kwd_const : kwd_const; - var : variable; - colon : colon; - param_type : type_expr -} - -and param_var = { - kwd_var : kwd_var; - var : variable; - colon : colon; - param_type : type_expr -} - -and block = { - opening : block_opening; - statements : statements; - terminator : semi option; - closing : block_closing -} - -and block_opening = - Block of kwd_block * lbrace -| Begin of kwd_begin - -and block_closing = - Block of rbrace -| End of kwd_end - -and statements = (statement, semi) nsepseq - -and statement = - Instr of instruction -| Data of data_decl - -and data_decl = - LocalConst of const_decl reg -| LocalVar of var_decl reg -| LocalFun of fun_decl reg - -and var_decl = { - kwd_var : kwd_var; - name : variable; - colon : colon; - var_type : type_expr; - assign : assign; - init : expr; - terminator : semi option -} - -and instruction = - Cond of conditional reg -| CaseInstr of if_clause case reg -| Assign of assignment reg -| Loop of loop -| ProcCall of fun_call -| Skip of kwd_skip -| RecordPatch of record_patch reg -| MapPatch of map_patch reg -| SetPatch of set_patch reg -| MapRemove of map_remove reg -| SetRemove of set_remove reg - -and set_remove = { - kwd_remove : kwd_remove; - element : expr; - kwd_from : kwd_from; - kwd_set : kwd_set; - set : path -} - -and map_remove = { - kwd_remove : kwd_remove; - key : expr; - kwd_from : kwd_from; - kwd_map : kwd_map; - map : path -} - -and set_patch = { - kwd_patch : kwd_patch; - path : path; - kwd_with : kwd_with; - set_inj : expr ne_injection reg -} - -and map_patch = { - kwd_patch : kwd_patch; - path : path; - kwd_with : kwd_with; - map_inj : binding reg ne_injection reg -} - -and binding = { - source : expr; - arrow : arrow; - image : expr -} - -and record_patch = { - kwd_patch : kwd_patch; - path : path; - kwd_with : kwd_with; - record_inj : field_assign reg ne_injection reg -} - -and cond_expr = { - kwd_if : kwd_if; - test : expr; - kwd_then : kwd_then; - ifso : expr; - terminator : semi option; - kwd_else : kwd_else; - ifnot : expr -} - -and conditional = { - kwd_if : kwd_if; - test : expr; - kwd_then : kwd_then; - ifso : if_clause; - terminator : semi option; - kwd_else : kwd_else; - ifnot : if_clause -} - -and if_clause = - ClauseInstr of instruction -| ClauseBlock of clause_block - -and clause_block = - LongBlock of block reg -| ShortBlock of (statements * semi option) braces reg - -and set_membership = { - set : expr; - kwd_contains : kwd_contains; - element : expr -} - -and 'a case = { - kwd_case : kwd_case; - expr : expr; - opening : opening; - lead_vbar : vbar option; - cases : ('a case_clause reg, vbar) nsepseq reg; - closing : closing -} - -and 'a case_clause = { - pattern : pattern; - arrow : arrow; - rhs : 'a -} - -and assignment = { - lhs : lhs; - assign : assign; - rhs : rhs; -} - -and lhs = - Path of path -| MapPath of map_lookup reg - -and rhs = expr - -and loop = - While of while_loop reg -| For of for_loop - -and while_loop = { - kwd_while : kwd_while; - cond : expr; - block : block reg -} - -and for_loop = - ForInt of for_int reg -| ForCollect of for_collect reg - -and for_int = { - kwd_for : kwd_for; - assign : var_assign reg; - kwd_to : kwd_to; - bound : expr; - block : block reg -} - -and var_assign = { - name : variable; - assign : assign; - expr : expr -} - -and for_collect = { - kwd_for : kwd_for; - var : variable; - bind_to : (arrow * variable) option; - kwd_in : kwd_in; - collection : collection; - expr : expr; - block : block reg -} - -and collection = - Map of kwd_map -| Set of kwd_set -| List of kwd_list - -(* Expressions *) - -and expr = - ECase of expr case reg -| ECond of cond_expr reg -| EAnnot of annot_expr reg -| ELogic of logic_expr -| EArith of arith_expr -| EString of string_expr -| EList of list_expr -| ESet of set_expr -| EConstr of constr_expr -| ERecord of field_assign reg ne_injection reg -| EProj of projection reg -| EMap of map_expr -| EVar of Lexer.lexeme reg -| ECall of fun_call -| EBytes of (Lexer.lexeme * Hex.t) reg -| EUnit of c_Unit -| ETuple of tuple_expr -| EPar of expr par reg -| EFun of fun_expr reg - -and annot_expr = (expr * type_expr) - -and set_expr = - SetInj of expr injection reg -| SetMem of set_membership reg - -and 'a injection = { - opening : opening; - elements : ('a, semi) sepseq; - terminator : semi option; - closing : closing -} - -and 'a ne_injection = { - opening : opening; - ne_elements : ('a, semi) nsepseq; - terminator : semi option; - closing : closing -} - -and opening = - Kwd of keyword -| KwdBracket of keyword * lbracket - -and closing = - End of kwd_end -| RBracket of rbracket - -and map_expr = - MapLookUp of map_lookup reg -| MapInj of binding reg injection reg -| BigMapInj of binding reg injection reg - -and map_lookup = { - path : path; - index : expr brackets reg -} - -and path = - Name of variable -| Path of projection reg - -and logic_expr = - BoolExpr of bool_expr -| CompExpr of comp_expr - -and bool_expr = - Or of kwd_or bin_op reg -| And of kwd_and bin_op reg -| Not of kwd_not un_op reg -| False of c_False -| True of c_True - -and 'a bin_op = { - op : 'a; - arg1 : expr; - arg2 : expr -} - -and 'a un_op = { - op : 'a; - arg : expr -} - -and comp_expr = - Lt of lt bin_op reg -| Leq of leq bin_op reg -| Gt of gt bin_op reg -| Geq of geq bin_op reg -| Equal of equal bin_op reg -| Neq of neq bin_op reg - -and arith_expr = - Add of plus bin_op reg -| Sub of minus bin_op reg -| Mult of times bin_op reg -| Div of slash bin_op reg -| Mod of kwd_mod bin_op reg -| Neg of minus un_op reg -| Int of (Lexer.lexeme * Z.t) reg -| Nat of (Lexer.lexeme * Z.t) reg -| Mutez of (Lexer.lexeme * Z.t) reg - -and string_expr = - Cat of cat bin_op reg -| String of Lexer.lexeme reg - -and list_expr = - ECons of cons bin_op reg -| EListComp of expr injection reg -| ENil of kwd_nil - -and constr_expr = - SomeApp of (c_Some * arguments) reg -| NoneExpr of c_None -| ConstrApp of (constr * arguments option) reg - -and field_assign = { - field_name : field_name; - equal : equal; - field_expr : expr -} - -and projection = { - struct_name : variable; - selector : dot; - field_path : (selection, dot) nsepseq -} - -and selection = - FieldName of field_name -| Component of (Lexer.lexeme * Z.t) reg - -and tuple_expr = (expr, comma) nsepseq par reg - -and fun_call = (expr * arguments) reg - -and arguments = tuple_expr - -(* Patterns *) - -and pattern = - PConstr of constr_pattern -| PVar of Lexer.lexeme reg -| PWild of wild -| PInt of (Lexer.lexeme * Z.t) reg -| PNat of (Lexer.lexeme * Z.t) reg -| PBytes of (Lexer.lexeme * Hex.t) reg -| PString of Lexer.lexeme reg -| PList of list_pattern -| PTuple of tuple_pattern - -and constr_pattern = - PUnit of c_Unit -| PFalse of c_False -| PTrue of c_True -| PNone of c_None -| PSomeApp of (c_Some * pattern par reg) reg -| PConstrApp of (constr * tuple_pattern option) reg - -and tuple_pattern = (pattern, comma) nsepseq par reg - -and list_pattern = - PListComp of pattern injection reg -| PNil of kwd_nil -| PParCons of (pattern * cons * pattern) par reg -| PCons of (pattern, cons) nsepseq reg - -(* Projecting regions *) - -val type_expr_to_region : type_expr -> Region.t -val expr_to_region : expr -> Region.t -val instr_to_region : instruction -> Region.t -val pattern_to_region : pattern -> Region.t -val path_to_region : path -> Region.t -val lhs_to_region : lhs -> Region.t -val rhs_to_region : rhs -> Region.t -val if_clause_to_region : if_clause -> Region.t -val selection_to_region : selection -> Region.t - -(* Extracting variables from patterns *) - -module VSet : Set.S with type elt = string Region.reg - -val vars_of_pattern : pattern -> VSet.t diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index efff9226f..f12cbf035 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -6,60 +6,7 @@ open Region open AST -module SSet = Utils.String.Set - -let reserved = - let open SSet in - empty - |> add "get_force" - |> add "get_chain_id" - |> add "transaction" - |> add "get_contract" - |> add "get_entrypoint" - |> add "size" - |> add "int" - |> add "abs" - |> add "is_nat" - |> add "amount" - |> add "balance" - |> add "now" - |> add "unit" - |> add "source" - |> add "sender" - |> add "failwith" - |> add "bitwise_or" - |> add "bitwise_and" - |> add "bitwise_xor" - |> add "string_concat" - |> add "string_slice" - |> add "crypto_check" - |> add "crypto_hash_key" - |> add "bytes_concat" - |> add "bytes_slice" - |> add "bytes_pack" - |> add "bytes_unpack" - |> add "set_empty" - |> add "set_mem" - |> add "set_add" - |> add "set_remove" - |> add "set_iter" - |> add "set_fold" - |> add "list_iter" - |> add "list_fold" - |> add "list_map" - |> add "map_iter" - |> add "map_map" - |> add "map_fold" - |> add "map_remove" - |> add "map_update" - |> add "map_get" - |> add "map_mem" - |> add "sha_256" - |> add "sha_512" - |> add "blake2b" - |> add "cons" - - (* END HEADER *) +(* END HEADER *) %} (* See [ParToken.mly] for the definition of tokens. *) @@ -171,10 +118,7 @@ declaration: type_decl: "type" type_name "is" type_expr ";"? { - let () = - if SSet.mem $2.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name $2)) in + ignore (SyntaxError.check_reserved_name $2); let stop = match $5 with Some region -> region @@ -242,14 +186,7 @@ type_tuple: sum_type: "|"? nsepseq(variant,"|") { - let add acc {value; _} = - if VSet.mem value.constr acc then - let open! SyntaxError in - raise (Error (Duplicate_variant value.constr)) - else VSet.add value.constr acc in - let variants = - Utils.nsepseq_foldl add VSet.empty $2 in - let () = ignore variants in + SyntaxError.check_variants (Utils.nsepseq_to_list $2); let region = nsepseq_to_region (fun x -> x.region) $2 in TSum {region; value=$2} } @@ -263,6 +200,8 @@ variant: record_type: "record" sep_or_term_list(field_decl,";") "end" { let ne_elements, terminator = $2 in + let () = Utils.nsepseq_to_list ne_elements + |> SyntaxError.check_fields in let region = cover $1 $3 and value = {opening = Kwd $1; ne_elements; @@ -290,13 +229,7 @@ fun_expr: "function" fun_name? parameters ":" type_expr "is" block "with" expr { - let () = - match $2 with - Some name -> - if SSet.mem name.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name name)) - | None -> () in + let () = SyntaxError.check_reserved_name_opt $2 in let stop = expr_to_region $9 in let region = cover $1 stop and value = {kwd_function = $1; @@ -309,13 +242,7 @@ fun_expr: return = $9} in {region; value} } | "function" fun_name? parameters ":" type_expr "is" expr { - let () = - match $2 with - Some name -> - if SSet.mem name.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name name)) - | None -> () in + let () = SyntaxError.check_reserved_name_opt $2 in let stop = expr_to_region $7 in let region = cover $1 stop and value = {kwd_function = $1; @@ -346,47 +273,28 @@ open_fun_decl: parameters: par(nsepseq(param_decl,";")) { - let open! AST in - let contents : (param_decl, semi) Utils.nsepseq par reg = $1 in - let add acc = function - ParamConst {value; _} -> - if VSet.mem value.var acc then - let open! SyntaxError in - raise (Error (Duplicate_parameter value.var)) - else VSet.add value.var acc - | ParamVar {value; _} -> - if VSet.mem value.var acc then - let open! SyntaxError in - raise (Error (Duplicate_parameter value.var)) - else VSet.add value.var acc in let params = - Utils.nsepseq_foldl add VSet.empty contents.value.inside in - let () = ignore params - in $1 } + Utils.nsepseq_to_list ($1.value: _ par).inside + in SyntaxError.check_parameters params; + $1 } param_decl: "var" var ":" param_type { - let () = - if SSet.mem $2.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name $2)) in + let var = SyntaxError.check_reserved_name $2 in let stop = type_expr_to_region $4 in let region = cover $1 stop and value = {kwd_var = $1; - var = $2; + var; colon = $3; param_type = $4} in ParamVar {region; value} } | "const" var ":" param_type { - let () = - if SSet.mem $2.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name $2)) in + let var = SyntaxError.check_reserved_name $2 in let stop = type_expr_to_region $4 in let region = cover $1 stop and value = {kwd_const = $1; - var = $2; + var; colon = $3; param_type = $4} in ParamConst {region; value} } @@ -450,12 +358,9 @@ open_var_decl: unqualified_decl(OP): var ":" type_expr OP expr { - let () = - if SSet.mem $1.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name $1)) in + let var = SyntaxError.check_reserved_name $1 in let region = expr_to_region $5 - in $1, $2, $3, $4, $5, region } + in var, $2, $3, $4, $5, region } const_decl: open_const_decl ";"? { @@ -662,14 +567,7 @@ cases(rhs): case_clause(rhs): pattern "->" rhs { - let vars = AST.vars_of_pattern $1 in - let is_reserved elt = SSet.mem elt.value reserved in - let inter = VSet.filter is_reserved vars in - let () = - if not (VSet.is_empty inter) then - let clash = VSet.choose inter in - let open! SyntaxError in - raise (Error (Reserved_name clash)) in + SyntaxError.check_pattern $1; fun rhs_to_region -> let start = pattern_to_region $1 in let region = cover start (rhs_to_region $3) @@ -711,13 +609,10 @@ for_loop: in For (ForInt {region; value}) } | "for" var arrow_clause? "in" collection expr block { - let () = - if SSet.mem $2.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name $2)) in + let var = SyntaxError.check_reserved_name $2 in let region = cover $1 $7.region in let value = {kwd_for = $1; - var = $2; + var; bind_to = $3; kwd_in = $4; collection = $5; @@ -732,21 +627,13 @@ collection: var_assign: var ":=" expr { - let () = - if SSet.mem $1.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name $1)) in - let region = cover $1.region (expr_to_region $3) - and value = {name=$1; assign=$2; expr=$3} + let name = SyntaxError.check_reserved_name $1 in + let region = cover name.region (expr_to_region $3) + and value = {name; assign=$2; expr=$3} in {region; value} } arrow_clause: - "->" var { - let () = - if SSet.mem $2.value reserved then - let open! SyntaxError in - raise (Error (Reserved_name $2)) - in $1,$2 } + "->" var { $1, SyntaxError.check_reserved_name $2 } (* Expressions *) diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index 8ed914f1b..b3b0936a0 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -64,10 +64,42 @@ let () = let () = Unit.close_all () in let token = MyLexer.Token.mk_constr name.Region.value name.Region.region in - let point = "Duplicate variant in this type declaration.\n\ + let point = "Duplicate variant in this sum type declaration.\n\ Hint: Change the name.\n", None, token in let error = Unit.format_error ~offsets:IO.options#offsets IO.options#mode point in Printf.eprintf "\027[31m%s\027[0m%!" error + + | Error (Non_linear_pattern var) -> + let () = Unit.close_all () in + let token = + MyLexer.Token.mk_ident var.Region.value var.Region.region in + (match token with + Stdlib.Error _ -> + assert false (* Should not fail if [name] is valid. *) + | Ok invalid -> + let point = "Repeated variable in this pattern.\n\ + Hint: Change the name.\n", + None, invalid in + let error = + Unit.format_error ~offsets:IO.options#offsets + IO.options#mode point + in Printf.eprintf "\027[31m%s\027[0m%!" error) + + | Error (Duplicate_field name) -> + let () = Unit.close_all () in + let token = + MyLexer.Token.mk_ident name.Region.value name.Region.region in + (match token with + Stdlib.Error _ -> + assert false (* Should not fail if [name] is valid. *) + | Ok invalid -> + let point = "Duplicate field name in this record declaration.\n\ + Hint: Change the name.\n", + None, invalid in + let error = + Unit.format_error ~offsets:IO.options#offsets + IO.options#mode point + in Printf.eprintf "\027[31m%s\027[0m%!" error) diff --git a/src/passes/1-parser/pascaligo/SyntaxError.ml b/src/passes/1-parser/pascaligo/SyntaxError.ml index 4bdc77d88..d402be17e 100644 --- a/src/passes/1-parser/pascaligo/SyntaxError.ml +++ b/src/passes/1-parser/pascaligo/SyntaxError.ml @@ -1,8 +1,185 @@ +[@@@warning "-42"] + type t = - Reserved_name of string Region.reg -| Duplicate_parameter of string Region.reg -| Duplicate_variant of string Region.reg + Reserved_name of AST.variable +| Duplicate_parameter of AST.variable +| Duplicate_variant of AST.variable +| Non_linear_pattern of AST.variable +| Duplicate_field of AST.variable type error = t exception Error of t + +open Region + +(* Useful modules *) + +module SSet = Utils.String.Set + +module Ord = + struct + type t = AST.variable + let compare v1 v2 = + compare v1.value v2.value + end + +module VarSet = Set.Make (Ord) + +(* Checking the definition of reserved names (shadowing) *) + +let reserved = + let open SSet in + empty + |> add "get_force" + |> add "get_chain_id" + |> add "transaction" + |> add "get_contract" + |> add "get_entrypoint" + |> add "size" + |> add "int" + |> add "abs" + |> add "is_nat" + |> add "amount" + |> add "balance" + |> add "now" + |> add "unit" + |> add "source" + |> add "sender" + |> add "failwith" + |> add "bitwise_or" + |> add "bitwise_and" + |> add "bitwise_xor" + |> add "string_concat" + |> add "string_slice" + |> add "crypto_check" + |> add "crypto_hash_key" + |> add "bytes_concat" + |> add "bytes_slice" + |> add "bytes_pack" + |> add "bytes_unpack" + |> add "set_empty" + |> add "set_mem" + |> add "set_add" + |> add "set_remove" + |> add "set_iter" + |> add "set_fold" + |> add "list_iter" + |> add "list_fold" + |> add "list_map" + |> add "map_iter" + |> add "map_map" + |> add "map_fold" + |> add "map_remove" + |> add "map_update" + |> add "map_get" + |> add "map_mem" + |> add "sha_256" + |> add "sha_512" + |> add "blake2b" + |> add "cons" + |> add "address" + |> add "self_address" + |> add "implicit_account" + |> add "set_delegate" + +let check_reserved_names vars = + let is_reserved elt = SSet.mem elt.value reserved in + let inter = VarSet.filter is_reserved vars in + if not (VarSet.is_empty inter) then + let clash = VarSet.choose inter in + raise (Error (Reserved_name clash)) + else vars + +let check_reserved_name var = + if SSet.mem var.value reserved then + raise (Error (Reserved_name var)) + else var + +let check_reserved_name_opt = function + Some var -> ignore (check_reserved_name var) +| None -> () + +(* Checking the linearity of patterns *) + +open! AST + +let rec vars_of_pattern env = function + PConstr p -> vars_of_pconstr env p +| PWild _ | PInt _ | PNat _ | PBytes _ | PString _ -> env +| PList l -> vars_of_plist env l +| PTuple t -> vars_of_ptuple env t.value +| PVar var -> + if VarSet.mem var env then + raise (Error (Non_linear_pattern var)) + else VarSet.add var env + +and vars_of_pconstr env = function + PUnit _ | PFalse _ | PTrue _ | PNone _ -> env +| PSomeApp {value=_, {value={inside; _};_}; _} -> + vars_of_pattern env inside +| PConstrApp {value=_, Some tuple; _} -> + vars_of_ptuple env tuple.value +| PConstrApp {value=_,None; _} -> env + +and vars_of_plist env = function + PListComp {value; _} -> + vars_of_pinj env value +| PNil _ -> + env +| PParCons {value={inside; _}; _} -> + let head, _, tail = inside in + vars_of_pattern (vars_of_pattern env head) tail +| PCons {value; _} -> + Utils.nsepseq_foldl vars_of_pattern env value + +and vars_of_pinj env inj = + Utils.sepseq_foldl vars_of_pattern env inj.elements + +and vars_of_ptuple env {inside; _} = + Utils.nsepseq_foldl vars_of_pattern env inside + +let check_linearity = vars_of_pattern VarSet.empty + +(* Checking patterns *) + +let check_pattern p = + check_linearity p |> check_reserved_names |> ignore + +(* Checking variants for duplicates *) + +let check_variants variants = + let add acc {value; _} = + if VarSet.mem value.constr acc then + raise (Error (Duplicate_variant value.constr)) + else VarSet.add value.constr acc in + let variants = + List.fold_left add VarSet.empty variants + in ignore variants + +(* Checking parameters *) + +let check_parameters params = + let add acc = function + ParamConst {value; _} -> + if VarSet.mem value.var acc then + raise (Error (Duplicate_parameter value.var)) + else VarSet.add value.var acc + | ParamVar {value; _} -> + if VarSet.mem value.var acc then + raise (Error (Duplicate_parameter value.var)) + else VarSet.add value.var acc in + let params = + List.fold_left add VarSet.empty params + in ignore params + +(* Checking record fields *) + +let check_fields fields = + let add acc {value; _} = + if VarSet.mem (value: field_decl).field_name acc then + raise (Error (Duplicate_field value.field_name)) + else VarSet.add value.field_name acc in + let fields = + List.fold_left add VarSet.empty fields + in ignore fields diff --git a/src/passes/1-parser/pascaligo/SyntaxError.mli b/src/passes/1-parser/pascaligo/SyntaxError.mli index 4bdc77d88..ee3d96872 100644 --- a/src/passes/1-parser/pascaligo/SyntaxError.mli +++ b/src/passes/1-parser/pascaligo/SyntaxError.mli @@ -1,8 +1,26 @@ type t = - Reserved_name of string Region.reg -| Duplicate_parameter of string Region.reg -| Duplicate_variant of string Region.reg + Reserved_name of AST.variable +| Duplicate_parameter of AST.variable +| Duplicate_variant of AST.variable +| Non_linear_pattern of AST.variable +| Duplicate_field of AST.variable type error = t exception Error of t + +module Ord : + sig + type t = AST.variable + val compare : t -> t -> int + end + +module VarSet : Set.S with type elt = Ord.t + +val check_reserved_name : AST.variable -> AST.variable +val check_reserved_name_opt : AST.variable option -> unit +val check_reserved_names : VarSet.t -> VarSet.t +val check_pattern : AST.pattern -> unit +val check_variants : AST.variant Region.reg list -> unit +val check_parameters : AST.param_decl list -> unit +val check_fields : AST.field_decl Region.reg list -> unit diff --git a/src/passes/1-parser/pascaligo/dune b/src/passes/1-parser/pascaligo/dune index a75445932..66737b9c2 100644 --- a/src/passes/1-parser/pascaligo/dune +++ b/src/passes/1-parser/pascaligo/dune @@ -1,24 +1,42 @@ +;; Build of the lexer + (ocamllex LexToken) +;; Build of the parser + (menhir - (merge_into Parser) - (modules ParToken Parser) - (flags -la 1 --table --strict --explain --external-tokens LexToken)) + (merge_into Parser) + (modules ParToken Parser) + (flags -la 1 --table --strict --external-tokens LexToken)) + +;; Build of the parser as a library (library - (name parser_pascaligo) - (public_name ligo.parser.pascaligo) - (modules - SyntaxError AST pascaligo Parser ParserLog LexToken) - (libraries - menhirLib - parser_shared - hex - simple-utils - tezos-utils) - (preprocess - (pps bisect_ppx --conditional)) - (flags (:standard -open Parser_shared -open Simple_utils))) + (name parser_pascaligo) + (public_name ligo.parser.pascaligo) + (modules + SyntaxError AST pascaligo Parser ParserLog LexToken) + (libraries + menhirLib + parser_shared + hex + simple-utils + tezos-utils) + (preprocess + (pps bisect_ppx --conditional)) + (flags (:standard -open Parser_shared -open Simple_utils))) + +;; Build of the unlexer (for covering the +;; error states of the LR automaton) + +(executable + (name Unlexer) + (libraries str) + (preprocess + (pps bisect_ppx --conditional)) + (modules Unlexer)) + +;; Local build of a standalone lexer (executable (name LexerMain) @@ -29,6 +47,8 @@ (pps bisect_ppx --conditional)) (flags (:standard -open Parser_shared -open Parser_pascaligo))) +;; Local build of a standalone parser + (executable (name ParserMain) (libraries parser_pascaligo) @@ -37,25 +57,3 @@ (preprocess (pps bisect_ppx --conditional)) (flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo))) - -(executable - (name Unlexer) - (libraries str) - (preprocess - (pps bisect_ppx --conditional)) - (modules Unlexer)) - -;; Les deux directives (rule) qui suivent sont pour le dev local. -;; Il suffit de faire "dune build Parser.exe" pour avoir un Parser.exe dans le dossier. -;; Pour le purger, il faut faire "dune clean". -;(rule -; (targets Parser.exe) -; (deps ParserMain.exe) -; (action (copy ParserMain.exe Parser.exe)) -; (mode promote-until-clean)) - -;(rule -; (targets Lexer.exe) -; (deps LexerMain.exe) -; (action (copy LexerMain.exe Lexer.exe)) -; (mode promote-until-clean)) diff --git a/src/test/#multisig_tests.ml# b/src/test/#multisig_tests.ml# new file mode 100644 index 000000000..490bffff7 --- /dev/null +++ b/src/test/#multisig_tests.ml# @@ -0,0 +1,162 @@ +open Trace +open Test_helpers + +let type_file f = + let%bind (typed , state , _env) = Ligo.Compile.Wrapper.source_to_typed (Syntax_name "pascaligo") f in + ok @@ (typed,state) + +let get_program = + let s = ref None in + fun () -> match !s with + | Some s -> ok s + | None -> ( + let%bind program = type_file "./contracts/multisig.ligo" in + s := Some program ; + ok program + ) + +let compile_main () = + let%bind program,_ = get_program () in + let%bind michelson = Compile.Wrapper.typed_to_michelson_value_as_function program "main" in +" let%bind _ex_ty_value = Ligo.Run.Of_michelson.evaluate michelson in + ok () + +open Ast_simplified + +let init_storage threshold counter pkeys = + let keys = List.map + (fun el -> + let (_,pk_str,_) = str_keys el in + e_key @@ pk_str) + pkeys in + ez_e_record [ + ("id" , e_string "MULTISIG" ) ; + ("counter" , e_nat counter ) ; + ("threshold" , e_nat threshold) ; + ("auth" , e_typed_list keys t_key ) ; + ] + +let empty_op_list = + (e_typed_list [] t_operation) +let empty_message = e_lambda (Var.of_name "arguments") + (Some t_unit) (Some (t_list t_operation)) + empty_op_list +let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode + Tezos_base__TzPervasives.Chain_id.b58check_encoding + Tezos_base__TzPervasives.Chain_id.zero + +(* sign the message 'msg' with 'keys', if 'is_valid'=false the providid signature will be incorrect *) +let params counter msg keys is_validl = + let%bind program,_ = get_program () in + let aux = fun acc (key,is_valid) -> + let (_,_pk,sk) = key in + let (pkh,_,_) = str_keys key in + let payload = e_tuple + [ msg ; + e_nat counter ; + e_string (if is_valid then "MULTISIG" else "XX") ; + chain_id_zero ] in + let%bind signature = sign_message program payload sk in + ok @@ (e_pair (e_key_hash pkh) (e_signature signature))::acc in + let%bind signed_msgs = Trace.bind_fold_list aux [] (List.rev @@ List.combine keys is_validl) in + ok @@ e_constructor + "CheckMessage" + (ez_e_record [ + ("counter" , e_nat counter ) ; + ("message" , msg) ; + ("signatures" , e_typed_list signed_msgs (t_pair (t_key_hash,t_signature)) ) ; + ]) + +(* Provide one valid signature when the threshold is two of two keys *) +let not_enough_1_of_2 () = + let%bind program,_ = get_program () in + let exp_failwith = "Not enough signatures passed the check" in + let keys = gen_keys () in + let%bind test_params = params 0 empty_message [keys] [true] in + let%bind () = expect_string_failwith + program "main" (e_pair test_params (init_storage 2 0 [keys;gen_keys()])) exp_failwith in + ok () + +let unmatching_counter () = + let%bind program,_ = get_program () in + let exp_failwith = "Counters does not match" in + let keys = gen_keys () in + let%bind test_params = params 1 empty_message [keys] [true] in + let%bind () = expect_string_failwith + program "main" (e_pair test_params (init_storage 1 0 [keys])) exp_failwith in + ok () + +(* Provide one invalid signature (correct key but incorrect signature) + when the threshold is one of one key *) +let invalid_1_of_1 () = + let%bind program,_ = get_program () in + let exp_failwith = "Invalid signature" in + let keys = [gen_keys ()] in + let%bind test_params = params 0 empty_message keys [false] in + let%bind () = expect_string_failwith + program "main" (e_pair test_params (init_storage 1 0 keys)) exp_failwith in + ok () + +(* Provide one valid signature when the threshold is one of one key *) +let valid_1_of_1 () = + let%bind program,_ = get_program () in + let keys = gen_keys () in + let%bind () = expect_eq_n_trace_aux [0;1;2] program "main" + (fun n -> + let%bind params = params n empty_message [keys] [true] in + ok @@ e_pair params (init_storage 1 n [keys]) + ) + (fun n -> + ok @@ e_pair empty_op_list (init_storage 1 (n+1) [keys]) + ) in + ok () + +(* Provive two valid signatures when the threshold is two of three keys *) +let valid_2_of_3 () = + let%bind program,_ = get_program () in + let param_keys = [gen_keys (); gen_keys ()] in + let st_keys = param_keys @ [gen_keys ()] in + let%bind () = expect_eq_n_trace_aux [0;1;2] program "main" + (fun n -> + let%bind params = params n empty_message param_keys [true;true] in + ok @@ e_pair params (init_storage 2 n st_keys) + ) + (fun n -> + ok @@ e_pair empty_op_list (init_storage 2 (n+1) st_keys) + ) in + ok () + +(* Provide one invalid signature and two valid signatures when the threshold is two of three keys *) +let invalid_3_of_3 () = + let%bind program,_ = get_program () in + let valid_keys = [gen_keys() ; gen_keys()] in + let invalid_key = gen_keys () in + let param_keys = valid_keys @ [invalid_key] in + let st_keys = valid_keys @ [gen_keys ()] in + let%bind test_params = params 0 empty_message param_keys [false;true;true] in + let exp_failwith = "Invalid signature" in + let%bind () = expect_string_failwith + program "main" (e_pair test_params (init_storage 2 0 st_keys)) exp_failwith in + ok () + +(* Provide two valid signatures when the threshold is three of three keys *) +let not_enough_2_of_3 () = + let%bind program,_ = get_program () in + let valid_keys = [gen_keys() ; gen_keys()] in + let st_keys = gen_keys () :: valid_keys in + let%bind test_params = params 0 empty_message (valid_keys) [true;true] in + let exp_failwith = "Not enough signatures passed the check" in + let%bind () = expect_string_failwith + program "main" (e_pair test_params (init_storage 3 0 st_keys)) exp_failwith in + ok () + +let main = test_suite "Multisig" [ + test "compile" compile_main ; + test "unmatching_counter" unmatching_counter ; + test "valid_1_of_1" valid_1_of_1 ; + test "invalid_1_of_1" invalid_1_of_1 ; + test "not_enough_signature" not_enough_1_of_2 ; + test "valid_2_of_3" valid_2_of_3 ; + test "invalid_3_of_3" invalid_3_of_3 ; + test "not_enough_2_of_3" not_enough_2_of_3 ; + ] diff --git a/src/test/contracts/annotation.ligo b/src/test/contracts/annotation.ligo index 7f5e969f4..58fd3e8bc 100644 --- a/src/test/contracts/annotation.ligo +++ b/src/test/contracts/annotation.ligo @@ -1,5 +1,6 @@ (* Test that a string is cast to an address given a type annotation *) -const lst : list(int) = list [] ; +const lst : list(int) = list [] -const address : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ; +const my_address : address = + ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index bf312c53d..6277e1012 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -51,7 +51,7 @@ let annotation () : unit result = expect_eq_evaluate program "lst" (e_list []) in let%bind () = - expect_eq_evaluate program "address" (e_address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") + expect_eq_evaluate program "my_address" (e_address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") in ok ()