diff --git a/CHANGELOG.md b/CHANGELOG.md index 812aaafb0..dc0b56a81 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ ## [Unreleased] +## [Failwith do not fail](https://gitlab.com/ligolang/ligo/merge_requests/337) - 2020-01-17 +### Added +- running failing code in `ligo interpret`, `ligo dry-run`, `ligo run-function` will no longer be an error (return value : 0) + ## [1899dfe8d7285580b3aa30fab933ed589f8f1bc5] - 2020-01-08 ### Added - Partial application and OCaml-like currying behavior to CameLIGO & ReasonLIGO diff --git a/src/bin/cli.ml b/src/bin/cli.ml index a1275d78f..d8be0d864 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -196,15 +196,20 @@ let interpret = ok (mini_c_prg,state,env) | None -> ok ([],Typer.Solver.initial_state,Ast_typed.Environment.full_empty) in - let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) init_file in - let%bind simplified_exp = Compile.Of_source.compile_expression v_syntax expression in - let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in - let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in - let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in - let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in - let%bind value = Run.run ~options compiled_exp.expr compiled_exp.expr_ty in - let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_annotation value in - ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output + let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) init_file in + let%bind simplified_exp = Compile.Of_source.compile_expression v_syntax expression in + let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in + let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in + let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in + let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in + let%bind runres = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in + match runres with + | Fail fail_res -> + let%bind failstring = Run.failwith_to_string fail_res in + ok @@ Format.asprintf "%s" failstring + | Success value' -> + let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_annotation value' in + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format ) in @@ -262,10 +267,14 @@ let dry_run = let%bind args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in - let%bind michelson_output = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in - - let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in - ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output + let%bind runres = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in + match runres with + | Fail fail_res -> + let%bind failstring = Run.failwith_to_string fail_res in + ok @@ Format.asprintf "%s" failstring + | Success michelson_output -> + let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in @@ -287,11 +296,16 @@ let run_function = let%bind (typed_app,_) = Compile.Of_simplified.compile_expression ~env ~state app in let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in - let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in - let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in - let%bind michelson_output = Run.run ~options michelson.expr michelson.expr_ty in - let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in - ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output + let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in + let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in + let%bind runres = Run.run_expression ~options michelson.expr michelson.expr_ty in + match runres with + | Fail fail_res -> + let%bind failstring = Run.failwith_to_string fail_res in + ok @@ Format.asprintf "%s" failstring + | Success michelson_output -> + let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in + ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in @@ -308,8 +322,8 @@ let evaluate_value = let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in - let%bind michelson_output = Run.run ~options compiled.expr compiled.expr_ty in - let%bind simplified_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in + let%bind michelson_output = Run.run_no_failwith ~options compiled.expr compiled.expr_ty in + let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index fdd9826c9..7d0cf9eb5 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -8,7 +8,7 @@ let error_suggest: string = "\n If you're not sure how to fix this error, you ca * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/ * Ask a question on our Discord: https://discord.gg/9rhYaEt * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new -* Check the changelog by running 'ligo changelog'" +* Check the changelog by running 'ligo changelog'\n" let toplevel ~(display_format : display_format) (x : string result) : unit Term.ret = match x with diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 35bb1bc3b..cc22a7410 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -964,18 +964,14 @@ let%expect_test _ = * Check the changelog by running 'ligo changelog' |}] let%expect_test _ = - run_ligo_bad [ "run-function" ; contract "failwith.ligo" ; "failer" ; "1" ] ; + run_ligo_good [ "run-function" ; contract "failwith.ligo" ; "failer" ; "1" ] ; [%expect {| - ligo: Execution failed: {"value":"some_string","type":"string"} + failwith("some_string") |}] - - If you're not sure how to fix this error, you can - do one of the following: - - * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/ - * Ask a question on our Discord: https://discord.gg/9rhYaEt - * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new - * Check the changelog by running 'ligo changelog' |}] +let%expect_test _ = + run_ligo_good [ "run-function" ; contract "failwith.ligo" ; "failer" ; "1" ; "--format=json" ] ; + [%expect {| + {"status":"ok","content":"failwith(\"some_string\")"} |}] let%expect_test _ = run_ligo_bad [ "compile-contract" ; contract "bad_address_format.religo" ; "main" ] ; @@ -1024,15 +1020,7 @@ let%expect_test _ = let%expect_test _ = (* TODO should not be bad? *) - run_ligo_bad [ "dry-run" ; contract "subtle_nontail_fail.mligo" ; "main" ; "()" ; "()" ] ; + run_ligo_good [ "dry-run" ; contract "subtle_nontail_fail.mligo" ; "main" ; "()" ; "()" ] ; [%expect {| - ligo: error of execution - - If you're not sure how to fix this error, you can - do one of the following: - - * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/ - * Ask a question on our Discord: https://discord.gg/9rhYaEt - * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new - * Check the changelog by running 'ligo changelog' |}] + failwith("This contract always fails") |}] diff --git a/src/main/display.ml b/src/main/display.ml index 9bea4ca56..ee9356b79 100644 --- a/src/main/display.ml +++ b/src/main/display.ml @@ -57,14 +57,14 @@ let result_pp_hr f out (r : _ result) = | Ok (s , _) -> Format.fprintf out "%a" f s | Error e -> Format.fprintf out "%a" (error_pp ~dev:false) (e ()) -let string_result_pp_hr = result_pp_hr (fun out s -> Format.fprintf out "%s" s) +let string_result_pp_hr = result_pp_hr (fun out s -> Format.fprintf out "%s\n" s) let result_pp_dev f out (r : _ result) = match r with | Ok (s , _) -> Format.fprintf out "%a" f s | Error e -> Format.fprintf out "%a" (error_pp ~dev:true) (e ()) -let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s" s) +let string_result_pp_dev = result_pp_hr (fun out s -> Format.fprintf out "%s\n" s) let json_pp out x = Format.fprintf out "%s" (J.to_string x) @@ -75,10 +75,10 @@ let string_result_pp_json out (r : string result) = ]) in match r with | Ok (x , _) -> ( - Format.fprintf out "%a" json_pp (status_json "ok" (`String x)) + Format.fprintf out "%a\n" json_pp (status_json "ok" (`String x)) ) | Error e -> ( - Format.fprintf out "%a" json_pp (status_json "error" (e ())) + Format.fprintf out "%a\n" json_pp (status_json "error" (e ())) ) type display_format = [ diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 03543a5c0..b8222d44c 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -9,32 +9,40 @@ module Errors = struct let message () = "only bytes, string or int are printable" in error title message - let failwith data_str type_str () = + let failwith str () = let title () = "Execution failed" in let message () = "" in let data = [ - ("value" , fun () -> Format.asprintf "%s" data_str); - ("type" , fun () -> Format.asprintf "%s" type_str); + ("value" , fun () -> Format.asprintf "%s" str); ] in error ~data title message end -type options = Memory_proto_alpha.options -type run_res = - | Success of ex_typed_value - | Fail of Memory_proto_alpha.Protocol.Script_repr.expr +type options = Memory_proto_alpha.options type run_failwith_res = | Failwith_int of int | Failwith_string of string | Failwith_bytes of bytes +type run_res = + | Success of ex_typed_value + | Fail of run_failwith_res + type dry_run_options = { amount : string ; predecessor_timestamp : string option ; sender : string option ; source : string option } +let failwith_to_string (f:run_failwith_res) : string result = + let%bind str = match f with + | Failwith_int i -> ok @@ string_of_int i + | Failwith_string s -> ok @@ Format.asprintf "\"%s\"" (String.escaped s) + | Failwith_bytes b -> + ok @@ Format.asprintf "0X%a" Hex.pp (Hex.of_bytes b) in + ok @@ Format.asprintf "failwith(%s)" str + let make_dry_run_options (opts : dry_run_options) : options result = let open Proto_alpha_utils.Trace in let open Proto_alpha_utils.Memory_proto_alpha in @@ -88,7 +96,7 @@ let fetch_lambda_types (contract_ty:ex_ty) = | Ex_ty (Lambda_t (in_ty, out_ty, _)) -> ok (Ex_ty in_ty, Ex_ty out_ty) | _ -> simple_fail "failed to fetch lambda types" -let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) : ex_typed_value result = +let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) : run_res result = let open! Tezos_raw_protocol_005_PsBabyM1 in let%bind (Ex_ty input_ty, Ex_ty output_ty) = fetch_lambda_types exp_type in let%bind input = @@ -105,11 +113,18 @@ let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Mi Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ Memory_proto_alpha.parse_michelson_fail ~top_level exp ty_stack_before ty_stack_after in let open! Memory_proto_alpha.Protocol.Script_interpreter in - let%bind (Item(output, Empty)) = + let%bind res = Trace.trace_tzresult_lwt (simple_error "error of execution") @@ - Memory_proto_alpha.interpret ?options descr - (Item(input, Empty)) in - ok (Ex_typed_value (output_ty, output)) + Memory_proto_alpha.failure_interpret ?options descr (Item(input, Empty)) in + match res with + | Memory_proto_alpha.Succeed stack -> + let (Item(output, Empty)) = stack in + ok @@ Success (Ex_typed_value (output_ty, output)) + | Memory_proto_alpha.Fail expr -> ( match Tezos_micheline.Micheline.root @@ Memory_proto_alpha.strings_of_prims expr with + | Int (_ , i) -> ok @@ Fail (Failwith_int (Z.to_int i)) + | String (_ , s) -> ok @@ Fail (Failwith_string s) + | Bytes (_, s) -> ok @@ Fail (Failwith_bytes s) + | _ -> fail @@ Errors.unknown_failwith_type () ) let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result = let open! Tezos_raw_protocol_005_PsBabyM1 in @@ -129,30 +144,28 @@ let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result | Memory_proto_alpha.Succeed stack -> let (Item(output, Empty)) = stack in ok @@ Success (Ex_typed_value (exp_type', output)) - | Memory_proto_alpha.Fail expr -> - ok (Fail expr) - -let run ?options (exp:Michelson.t) (exp_type:ex_ty) : ex_typed_value result = - let%bind expr = run_expression ?options exp exp_type in - match expr with - | Success res -> ok res - | Fail res -> ( match Tezos_micheline.Micheline.root @@ Memory_proto_alpha.strings_of_prims res with - | Int (_ , i) -> fail @@ Errors.failwith (Z.to_string i) "int" () - | String (_ , s) -> fail @@ Errors.failwith s "string" () - | Bytes (_, s) -> fail @@ Errors.failwith (Bytes.to_string s) "bytes" () + | Memory_proto_alpha.Fail expr -> ( match Tezos_micheline.Micheline.root @@ Memory_proto_alpha.strings_of_prims expr with + | Int (_ , i) -> ok @@ Fail (Failwith_int (Z.to_int i)) + | String (_ , s) -> ok @@ Fail (Failwith_string s) + | Bytes (_, s) -> ok @@ Fail (Failwith_bytes s) | _ -> fail @@ Errors.unknown_failwith_type () ) - let run_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : run_failwith_res result = let%bind expr = run_expression ?options exp exp_type in match expr with - | Fail res -> ( match Tezos_micheline.Micheline.root @@ Memory_proto_alpha.strings_of_prims res with - | Int (_ , i) -> ok (Failwith_int (Z.to_int i)) - | String (_ , s) -> ok (Failwith_string s) - | Bytes (_, b) -> ok (Failwith_bytes b) - | _ -> simple_fail "Unknown failwith type" ) - | _ -> simple_fail "An error of execution was expected" + | Success _ -> simple_fail "An error of execution was expected" + | Fail res -> ok res + +let run_no_failwith ?options (exp:Michelson.t) (exp_type:ex_ty) : ex_typed_value result = + let%bind expr = run_expression ?options exp exp_type in + match expr with + | Success tval -> ok tval + | Fail _ -> simple_fail "Unexpected error of execution" let evaluate_expression ?options exp exp_type = - let%bind etv = run ?options exp exp_type in - ex_value_ty_to_michelson etv \ No newline at end of file + let%bind etv = run_expression ?options exp exp_type in + match etv with + | Success etv' -> ex_value_ty_to_michelson etv' + | Fail res -> + let%bind str = failwith_to_string res in + fail @@ Errors.failwith str () diff --git a/src/passes/1-parser/cameligo/AST.ml b/src/passes/1-parser/cameligo/AST.ml index 3c99e0e5d..25104af3e 100644 --- a/src/passes/1-parser/cameligo/AST.ml +++ b/src/passes/1-parser/cameligo/AST.ml @@ -110,6 +110,7 @@ type type_name = string reg type field_name = string reg type type_constr = string reg type constr = string reg +type attribute = string reg (* Parentheses *) @@ -130,8 +131,10 @@ type t = { and ast = t +and attributes = attribute list + and declaration = - Let of (kwd_let * let_binding) reg + Let of (kwd_let * let_binding * attributes) reg | TypeDecl of type_decl reg (* Non-recursive values *) @@ -351,18 +354,19 @@ and 'a case_clause = { } and let_in = { - kwd_let : kwd_let; - binding : let_binding; - kwd_in : kwd_in; - body : expr + kwd_let : kwd_let; + binding : let_binding; + kwd_in : kwd_in; + body : expr; + attributes : attributes } and fun_expr = { - kwd_fun : kwd_fun; - binders : pattern nseq; - lhs_type : (colon * type_expr) option; - arrow : arrow; - body : expr + kwd_fun : kwd_fun; + binders : pattern nseq; + lhs_type : (colon * type_expr) option; + arrow : arrow; + body : expr; } and cond_expr = { diff --git a/src/passes/1-parser/cameligo/LexToken.mli b/src/passes/1-parser/cameligo/LexToken.mli index 79fd2519c..b71398b62 100644 --- a/src/passes/1-parser/cameligo/LexToken.mli +++ b/src/passes/1-parser/cameligo/LexToken.mli @@ -85,6 +85,7 @@ type t = | Mutez of (string * Z.t) Region.reg | String of string Region.reg | Bytes of (string * Hex.t) Region.reg +| Attr2 of string Region.reg (* Keywords *) @@ -137,6 +138,7 @@ type ident_err = Reserved_name type nat_err = Invalid_natural | Non_canonical_zero_nat type sym_err = Invalid_symbol +type attr_err = Invalid_attribute type kwd_err = Invalid_keyword val mk_int : lexeme -> Region.t -> (token, int_err) result @@ -148,6 +150,8 @@ val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result val mk_string : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token +val mk_attr : lexeme -> Region.t -> (token, attr_err) result +val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result val eof : Region.t -> token (* Predicates *) diff --git a/src/passes/1-parser/cameligo/LexToken.mll b/src/passes/1-parser/cameligo/LexToken.mll index d989d1186..f0bd0d319 100644 --- a/src/passes/1-parser/cameligo/LexToken.mll +++ b/src/passes/1-parser/cameligo/LexToken.mll @@ -69,6 +69,7 @@ type t = | Mutez of (string * Z.t) Region.reg | String of string Region.reg | Bytes of (string * Hex.t) Region.reg +| Attr2 of string Region.reg (* Keywords *) @@ -163,10 +164,9 @@ let proj_token = function | True region -> region, "True" | Type region -> region, "Type" | With region -> region, "With" - | C_None region -> region, "C_None" | C_Some region -> region, "C_Some" - +| Attr2 Region.{region; value} -> region, sprintf "Attr2 %s" value | EOF region -> region, "EOF" let to_lexeme = function @@ -226,7 +226,7 @@ let to_lexeme = function | C_None _ -> "None" | C_Some _ -> "Some" - +| Attr2 a -> a.Region.value | EOF _ -> "" let to_string token ?(offsets=true) mode = @@ -418,6 +418,8 @@ let eof region = EOF region type sym_err = Invalid_symbol +type attr_err = Invalid_attribute + let mk_sym lexeme region = match lexeme with (* Lexemes in common with all concrete syntaxes *) @@ -465,6 +467,14 @@ let mk_ident lexeme region = let mk_constr lexeme region = Lexing.from_string lexeme |> scan_constr region lexicon +(* Attributes *) + +let mk_attr _lexeme _region = + Error Invalid_attribute + +let mk_attr2 lexeme region = + Ok (Attr2 { value = lexeme; region }) + (* Predicates *) let is_string = function diff --git a/src/passes/1-parser/cameligo/ParToken.mly b/src/passes/1-parser/cameligo/ParToken.mly index 22610c0aa..0368fad57 100644 --- a/src/passes/1-parser/cameligo/ParToken.mly +++ b/src/passes/1-parser/cameligo/ParToken.mly @@ -12,6 +12,7 @@ %token <(string * Z.t) Region.reg> Mutez "" %token Ident "" %token Constr "" +%token Attr2 "" (* Symbols *) diff --git a/src/passes/1-parser/cameligo/Parser.mly b/src/passes/1-parser/cameligo/Parser.mly index a86e24d02..ced3d28f3 100644 --- a/src/passes/1-parser/cameligo/Parser.mly +++ b/src/passes/1-parser/cameligo/Parser.mly @@ -206,12 +206,13 @@ field_decl: (* Top-level non-recursive definitions *) let_declaration: - "let" let_binding { - let kwd_let = $1 in - let binding = $2 in - let value = kwd_let, binding in - let stop = expr_to_region binding.let_rhs in - let region = cover $1 stop + "let" let_binding seq(Attr2) { + let kwd_let = $1 in + let attributes = $3 in + let binding = $2 in + let value = kwd_let, binding, attributes in + let stop = expr_to_region binding.let_rhs in + let region = cover $1 stop in {region; value} } let_binding: @@ -451,25 +452,27 @@ case_clause(right_expr): {pattern=$1; arrow=$2; rhs=$3} } let_expr(right_expr): - "let" let_binding "in" right_expr { - let kwd_let = $1 - and binding = $2 - and kwd_in = $3 - and body = $4 in - let stop = expr_to_region body in - let region = cover kwd_let stop - and value = {kwd_let; binding; kwd_in; body} + "let" let_binding seq(Attr2) "in" right_expr { + let kwd_let = $1 + and binding = $2 + and attributes = $3 + and kwd_in = $4 + and body = $5 in + let stop = expr_to_region body in + let region = cover kwd_let stop + and value = {kwd_let; binding; kwd_in; body; attributes} in ELetIn {region; value} } fun_expr(right_expr): "fun" nseq(irrefutable) "->" right_expr { let stop = expr_to_region $4 in let region = cover $1 stop in - let value = {kwd_fun = $1; - binders = $2; - lhs_type = None; - arrow = $3; - body = $4} + let value = {kwd_fun = $1; + binders = $2; + lhs_type = None; + arrow = $3; + body = $4 + } in EFun {region; value} } disj_expr_level: diff --git a/src/passes/1-parser/cameligo/ParserLog.ml b/src/passes/1-parser/cameligo/ParserLog.ml index e10539e3e..0ee1bd3e6 100644 --- a/src/passes/1-parser/cameligo/ParserLog.ml +++ b/src/passes/1-parser/cameligo/ParserLog.ml @@ -128,10 +128,18 @@ let rec print_tokens state {decl;eof} = Utils.nseq_iter (print_statement state) decl; print_token state eof "EOF" +and print_attributes state attributes = + List.iter ( + fun ({value = attribute; region}) -> + let attribute_formatted = sprintf "[@%s]" attribute in + print_token state region attribute_formatted + ) attributes + and print_statement state = function - Let {value=kwd_let, let_binding; _} -> + Let {value=kwd_let, let_binding, attributes; _} -> print_token state kwd_let "let"; - print_let_binding state let_binding + print_let_binding state let_binding; + print_attributes state attributes | TypeDecl {value={kwd_type; name; eq; type_expr}; _} -> print_token state kwd_type "type"; print_var state name; @@ -530,9 +538,10 @@ and print_case_clause state {value; _} = print_expr state rhs and print_let_in state {value; _} = - let {kwd_let; binding; kwd_in; body} = value in + let {kwd_let; binding; kwd_in; body; attributes} = value in print_token state kwd_let "let"; print_let_binding state binding; + print_attributes state attributes; print_token state kwd_in "in"; print_expr state body @@ -601,9 +610,9 @@ let rec pp_ast state {decl; _} = List.iteri (List.length decls |> apply) decls and pp_declaration state = function - Let {value; region} -> + Let {value = (_, let_binding, _); region} -> pp_loc_node state "Let" region; - pp_let_binding state (snd value) + pp_let_binding state let_binding | TypeDecl {value; region} -> pp_loc_node state "TypeDecl" region; pp_type_decl state value diff --git a/src/passes/1-parser/pascaligo.ml b/src/passes/1-parser/pascaligo.ml index a86c5a5dd..64c169f06 100644 --- a/src/passes/1-parser/pascaligo.ml +++ b/src/passes/1-parser/pascaligo.ml @@ -56,6 +56,15 @@ module Errors = struct ] in error ~data title message + let detached_attributes (attrs: AST.attributes) = + let title () = "detached attributes" in + let message () = "" in + let data = [ + ("location", + fun () -> Format.asprintf "%a" Location.pp_lift @@ attrs.region) + ] in + error ~data title message + let parser_error source (start: Lexing.position) (end_: Lexing.position) lexbuf = let title () = "parser error" in let file = if source = "" then @@ -135,6 +144,8 @@ let parse (parser: 'a parser) source lexbuf = fail @@ (duplicate_variant name) | Scoping.Error (Reserved_name name) -> fail @@ (reserved_name name) + | SyntaxError.Error (Detached_attributes attrs) -> + fail @@ (detached_attributes attrs) | Parser.Error -> let start = Lexing.lexeme_start_p lexbuf in let end_ = Lexing.lexeme_end_p lexbuf in diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml index 7f41af532..a855ea46e 100644 --- a/src/passes/1-parser/pascaligo/AST.ml +++ b/src/passes/1-parser/pascaligo/AST.ml @@ -109,6 +109,7 @@ type field_name = string reg type map_name = string reg type set_name = string reg type constr = string reg +type attribute = string reg (* Parentheses *) @@ -143,6 +144,8 @@ type t = { and ast = t +and attributes = attribute list reg + and declaration = TypeDecl of type_decl reg | ConstDecl of const_decl reg @@ -155,7 +158,8 @@ and const_decl = { const_type : type_expr; equal : equal; init : expr; - terminator : semi option + terminator : semi option; + attributes : attributes; } (* Type declarations *) @@ -212,7 +216,8 @@ and fun_decl = { kwd_is : kwd_is; block_with : (block reg * kwd_with) option; return : expr; - terminator : semi option + terminator : semi option; + attributes : attributes; } and parameters = (param_decl, semi) nsepseq par reg @@ -268,7 +273,7 @@ and var_decl = { var_type : type_expr; assign : assign; init : expr; - terminator : semi option + terminator : semi option; } and instruction = diff --git a/src/passes/1-parser/pascaligo/LexToken.mli b/src/passes/1-parser/pascaligo/LexToken.mli index 0908eff3f..598b6de4f 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mli +++ b/src/passes/1-parser/pascaligo/LexToken.mli @@ -70,42 +70,43 @@ type t = (* Keywords *) -| And of Region.t (* "and" *) -| Begin of Region.t (* "begin" *) -| BigMap of Region.t (* "big_map" *) -| Block of Region.t (* "block" *) -| Case of Region.t (* "case" *) -| Const of Region.t (* "const" *) -| Contains of Region.t (* "contains" *) -| Else of Region.t (* "else" *) -| End of Region.t (* "end" *) -| False of Region.t (* "False" *) -| For of Region.t (* "for" *) -| From of Region.t (* "from" *) -| Function of Region.t (* "function" *) -| If of Region.t (* "if" *) -| In of Region.t (* "in" *) -| Is of Region.t (* "is" *) -| List of Region.t (* "list" *) -| Map of Region.t (* "map" *) -| Mod of Region.t (* "mod" *) -| Nil of Region.t (* "nil" *) -| Not of Region.t (* "not" *) -| Of of Region.t (* "of" *) -| Or of Region.t (* "or" *) -| Patch of Region.t (* "patch" *) -| Record of Region.t (* "record" *) -| Remove of Region.t (* "remove" *) -| Set of Region.t (* "set" *) -| Skip of Region.t (* "skip" *) -| Then of Region.t (* "then" *) -| To of Region.t (* "to" *) -| True of Region.t (* "True" *) -| Type of Region.t (* "type" *) -| Unit of Region.t (* "Unit" *) -| Var of Region.t (* "var" *) -| While of Region.t (* "while" *) -| With of Region.t (* "with" *) +| And of Region.t (* "and" *) +| Attributes of Region.t (* "attributes" *) +| Begin of Region.t (* "begin" *) +| BigMap of Region.t (* "big_map" *) +| Block of Region.t (* "block" *) +| Case of Region.t (* "case" *) +| Const of Region.t (* "const" *) +| Contains of Region.t (* "contains" *) +| Else of Region.t (* "else" *) +| End of Region.t (* "end" *) +| False of Region.t (* "False" *) +| For of Region.t (* "for" *) +| From of Region.t (* "from" *) +| Function of Region.t (* "function" *) +| If of Region.t (* "if" *) +| In of Region.t (* "in" *) +| Is of Region.t (* "is" *) +| List of Region.t (* "list" *) +| Map of Region.t (* "map" *) +| Mod of Region.t (* "mod" *) +| Nil of Region.t (* "nil" *) +| Not of Region.t (* "not" *) +| Of of Region.t (* "of" *) +| Or of Region.t (* "or" *) +| Patch of Region.t (* "patch" *) +| Record of Region.t (* "record" *) +| Remove of Region.t (* "remove" *) +| Set of Region.t (* "set" *) +| Skip of Region.t (* "skip" *) +| Then of Region.t (* "then" *) +| To of Region.t (* "to" *) +| True of Region.t (* "True" *) +| Type of Region.t (* "type" *) +| Unit of Region.t (* "Unit" *) +| Var of Region.t (* "var" *) +| While of Region.t (* "while" *) +| With of Region.t (* "with" *) (* Data constructors *) @@ -138,6 +139,7 @@ type ident_err = Reserved_name type nat_err = Invalid_natural | Non_canonical_zero_nat type sym_err = Invalid_symbol +type attr_err = Invalid_attribute type kwd_err = Invalid_keyword val mk_int : lexeme -> Region.t -> (token, int_err) result @@ -149,6 +151,8 @@ val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result val mk_string : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token +val mk_attr : lexeme -> Region.t -> (token, attr_err) result +val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result val eof : Region.t -> token (* Predicates *) diff --git a/src/passes/1-parser/pascaligo/LexToken.mll b/src/passes/1-parser/pascaligo/LexToken.mll index 51009bb76..5a1e47c76 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mll +++ b/src/passes/1-parser/pascaligo/LexToken.mll @@ -68,42 +68,43 @@ type t = (* Keywords *) -| And of Region.t (* "and" *) -| Begin of Region.t (* "begin" *) -| BigMap of Region.t (* "big_map" *) -| Block of Region.t (* "block" *) -| Case of Region.t (* "case" *) -| Const of Region.t (* "const" *) -| Contains of Region.t (* "contains" *) -| Else of Region.t (* "else" *) -| End of Region.t (* "end" *) -| False of Region.t (* "False" *) -| For of Region.t (* "for" *) -| From of Region.t (* "from" *) -| Function of Region.t (* "function" *) -| If of Region.t (* "if" *) -| In of Region.t (* "in" *) -| Is of Region.t (* "is" *) -| List of Region.t (* "list" *) -| Map of Region.t (* "map" *) -| Mod of Region.t (* "mod" *) -| Nil of Region.t (* "nil" *) -| Not of Region.t (* "not" *) -| Of of Region.t (* "of" *) -| Or of Region.t (* "or" *) -| Patch of Region.t (* "patch" *) -| Record of Region.t (* "record" *) -| Remove of Region.t (* "remove" *) -| Set of Region.t (* "set" *) -| Skip of Region.t (* "skip" *) -| Then of Region.t (* "then" *) -| To of Region.t (* "to" *) -| True of Region.t (* "True" *) -| Type of Region.t (* "type" *) -| Unit of Region.t (* "Unit" *) -| Var of Region.t (* "var" *) -| While of Region.t (* "while" *) -| With of Region.t (* "with" *) +| And of Region.t (* "and" *) +| Attributes of Region.t (* "attributes" *) +| Begin of Region.t (* "begin" *) +| BigMap of Region.t (* "big_map" *) +| Block of Region.t (* "block" *) +| Case of Region.t (* "case" *) +| Const of Region.t (* "const" *) +| Contains of Region.t (* "contains" *) +| Else of Region.t (* "else" *) +| End of Region.t (* "end" *) +| False of Region.t (* "False" *) +| For of Region.t (* "for" *) +| From of Region.t (* "from" *) +| Function of Region.t (* "function" *) +| If of Region.t (* "if" *) +| In of Region.t (* "in" *) +| Is of Region.t (* "is" *) +| List of Region.t (* "list" *) +| Map of Region.t (* "map" *) +| Mod of Region.t (* "mod" *) +| Nil of Region.t (* "nil" *) +| Not of Region.t (* "not" *) +| Of of Region.t (* "of" *) +| Or of Region.t (* "or" *) +| Patch of Region.t (* "patch" *) +| Record of Region.t (* "record" *) +| Remove of Region.t (* "remove" *) +| Set of Region.t (* "set" *) +| Skip of Region.t (* "skip" *) +| Then of Region.t (* "then" *) +| To of Region.t (* "to" *) +| True of Region.t (* "True" *) +| Type of Region.t (* "type" *) +| Unit of Region.t (* "Unit" *) +| Var of Region.t (* "var" *) +| While of Region.t (* "while" *) +| With of Region.t (* "with" *) (* Data constructors *) @@ -175,6 +176,7 @@ let proj_token = function (* Keywords *) | And region -> region, "And" +| Attributes region -> region, "Attributes" | Begin region -> region, "Begin" | BigMap region -> region, "BigMap" | Block region -> region, "Block" @@ -215,7 +217,7 @@ let proj_token = function | C_None region -> region, "C_None" | C_Some region -> region, "C_Some" - + (* Virtual tokens *) | EOF region -> region, "EOF" @@ -264,6 +266,7 @@ let to_lexeme = function (* Keywords *) | And _ -> "and" +| Attributes _ -> "attributes" | Begin _ -> "begin" | BigMap _ -> "big_map" | Block _ -> "block" @@ -321,6 +324,7 @@ let to_region token = proj_token token |> fst let keywords = [ (fun reg -> And reg); + (fun reg -> Attributes reg); (fun reg -> Begin reg); (fun reg -> BigMap reg); (fun reg -> Block reg); @@ -485,6 +489,8 @@ let eof region = EOF region type sym_err = Invalid_symbol +type attr_err = Invalid_attribute + let mk_sym lexeme region = match lexeme with (* Lexemes in common with all concrete syntaxes *) @@ -531,6 +537,14 @@ let mk_ident lexeme region = let mk_constr lexeme region = Lexing.from_string lexeme |> scan_constr region lexicon +(* Attributes *) + +let mk_attr _lexeme _region = + Error Invalid_attribute + +let mk_attr2 _lexeme _region = + Error Invalid_attribute + (* Predicates *) let is_string = function @@ -551,6 +565,7 @@ let is_ident = function let is_kwd = function And _ +| Attributes _ | Begin _ | BigMap _ | Block _ diff --git a/src/passes/1-parser/pascaligo/ParToken.mly b/src/passes/1-parser/pascaligo/ParToken.mly index 629ab9d85..11275b76e 100644 --- a/src/passes/1-parser/pascaligo/ParToken.mly +++ b/src/passes/1-parser/pascaligo/ParToken.mly @@ -45,6 +45,7 @@ (* Keywords *) %token And "and" +%token Attributes "attributes" %token Begin "begin" %token BigMap "big_map" %token Block "block" diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index bc679ed78..7325cd1df 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -6,6 +6,39 @@ open Region open AST +type statement_attributes_mixed = + PInstr of instruction +| PData of data_decl +| PAttributes of attributes + +let attributes_to_statement (statement, statements) = + if (List.length statements = 0) then + match statement with + | PInstr i -> Instr i, [] + | PData d -> Data d, [] + | PAttributes a -> + let open! SyntaxError in + raise (Error (Detached_attributes a)) + else ( + let statements = (Region.ghost, statement) :: statements in + let rec inner result = function + | (t, PData (LocalConst const)) :: (_, PAttributes a) :: rest -> + inner (result @ [(t, Data (LocalConst {const with value = {const.value with attributes = a}}))]) rest + | (t, PData (LocalFun func)) :: (_, PAttributes a) :: rest -> + inner (result @ [(t, Data (LocalFun {func with value = {func.value with attributes = a}}))]) rest + | (t, PData d) :: rest -> + inner (result @ [(t, Data d)]) rest + | (t, PInstr i) :: rest -> + inner (result @ [(t, Instr i)]) rest + | (_, PAttributes _) :: rest -> + inner result rest + | [] -> + result + in + let result = inner [] statements in + (snd (List.hd result), List.tl result) + ) + (* END HEADER *) %} @@ -112,7 +145,7 @@ contract: declaration: type_decl { TypeDecl $1 } | const_decl { ConstDecl $1 } -| fun_decl { FunDecl $1 } +| fun_decl { FunDecl $1 } (* Type declarations *) @@ -225,6 +258,7 @@ field_decl: and value = {field_name=$1; colon=$2; field_type=$3} in {region; value} } + fun_expr: "function" parameters ":" type_expr "is" expr { let stop = expr_to_region $6 in @@ -234,7 +268,8 @@ fun_expr: colon = $3; ret_type = $4; kwd_is = $5; - return = $6} + return = $6 + } in {region; value} } (* Function declarations *) @@ -254,7 +289,8 @@ open_fun_decl: kwd_is = $6; block_with = Some ($7, $8); return = $9; - terminator = None} + terminator = None; + attributes = {value = []; region = Region.ghost}} in {region; value} } | "function" fun_name parameters ":" type_expr "is" expr { Scoping.check_reserved_name $2; @@ -268,12 +304,15 @@ open_fun_decl: kwd_is = $6; block_with = None; return = $7; - terminator = None} + terminator = None; + attributes = {value = []; region = Region.ghost}} in {region; value} } fun_decl: - open_fun_decl ";"? { - {$1 with value = {$1.value with terminator=$2}} } + open_fun_decl semi_attributes { + let attributes, terminator = $2 in + {$1 with value = {$1.value with terminator = terminator; attributes = attributes}} + } parameters: par(nsepseq(param_decl,";")) { @@ -311,7 +350,7 @@ block: let statements, terminator = $2 in let region = cover $1 $3 and value = {opening = Begin $1; - statements; + statements = attributes_to_statement statements; terminator; closing = End $3} in {region; value} @@ -320,14 +359,15 @@ block: let statements, terminator = $3 in let region = cover $1 $4 and value = {opening = Block ($1,$2); - statements; + statements = attributes_to_statement statements; terminator; closing = Block $4} in {region; value} } statement: - instruction { Instr $1 } -| open_data_decl { Data $1 } + instruction { PInstr $1 } +| open_data_decl { PData $1 } +| attributes { PAttributes $1 } open_data_decl: open_const_decl { LocalConst $1 } @@ -344,9 +384,11 @@ open_const_decl: const_type; equal; init; - terminator = None} + terminator = None; + attributes = {value = []; region = Region.ghost}} in {region; value} } + open_var_decl: "var" unqualified_decl(":=") { let name, colon, var_type, assign, init, stop = $2 in @@ -357,7 +399,8 @@ open_var_decl: var_type; assign; init; - terminator = None} + terminator = None; + } in {region; value} } unqualified_decl(OP): @@ -366,9 +409,23 @@ unqualified_decl(OP): let region = expr_to_region $5 in $1, $2, $3, $4, $5, region } +attributes: + "attributes" "[" nsepseq(String,";") "]" { + let region = cover $1 $4 in + let value = (Utils.nsepseq_to_list $3) in + {region; value} + } + +semi_attributes: + /* empty */ { {value = []; region = Region.ghost}, None } + | ";" { {value = []; region = Region.ghost}, Some $1 } + | ";" attributes ";" { $2, Some $1 } + const_decl: - open_const_decl ";"? { - {$1 with value = {$1.value with terminator=$2}} } + open_const_decl semi_attributes { + let attributes, terminator = $2 in + {$1 with value = {$1.value with terminator = terminator; attributes = attributes }} + } instruction: conditional { Cond $1 } @@ -529,9 +586,10 @@ if_clause: clause_block: block { LongBlock $1 } | "{" sep_or_term_list(statement,";") "}" { + let statements, terminator = $2 in let region = cover $1 $3 in let value = {lbrace = $1; - inside = $2; + inside = attributes_to_statement statements, terminator; rbrace = $3} in ShortBlock {value; region} } diff --git a/src/passes/1-parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml index 1a6547751..4a186980e 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.ml +++ b/src/passes/1-parser/pascaligo/ParserLog.ml @@ -114,6 +114,13 @@ let rec print_tokens state ast = Utils.nseq_iter (print_decl state) decl; print_token state eof "EOF" +and print_attributes state attributes = + let attributes = List.fold_left (fun all a -> all ^ a.value ^ ";") "" attributes.value in + let line = + sprintf "attributes[%s]" + attributes + in Buffer.add_string state#buffer line + and print_decl state = function TypeDecl decl -> print_type_decl state decl | ConstDecl decl -> print_const_decl state decl @@ -121,14 +128,15 @@ and print_decl state = function and print_const_decl state {value; _} = let {kwd_const; name; colon; const_type; - equal; init; terminator} = value in + equal; init; terminator; attributes} = value in print_token state kwd_const "const"; print_var state name; print_token state colon ":"; print_type_expr state const_type; print_token state equal "="; print_expr state init; - print_terminator state terminator + print_terminator state terminator; + print_attributes state attributes and print_type_decl state {value; _} = let {kwd_type; name; kwd_is; @@ -198,7 +206,7 @@ and print_type_tuple state {value; _} = and print_fun_decl state {value; _} = let {kwd_function; fun_name; param; colon; ret_type; kwd_is; block_with; - return; terminator} = value in + return; terminator; attributes } = value in print_token state kwd_function "function"; print_var state fun_name; print_parameters state param; @@ -211,7 +219,8 @@ and print_fun_decl state {value; _} = print_block state block; print_token state kwd_with "with"); print_expr state return; - print_terminator state terminator + print_terminator state terminator; + print_attributes state attributes and print_fun_expr state {value; _} = let {kwd_function; param; colon; diff --git a/src/passes/1-parser/pascaligo/Scoping.ml b/src/passes/1-parser/pascaligo/Scoping.ml index 73a7012ac..a69b83381 100644 --- a/src/passes/1-parser/pascaligo/Scoping.ml +++ b/src/passes/1-parser/pascaligo/Scoping.ml @@ -7,6 +7,7 @@ type t = | Duplicate_variant of AST.variable | Non_linear_pattern of AST.variable | Duplicate_field of AST.variable +| Detached_attributes of AST.attributes type error = t diff --git a/src/passes/1-parser/reasonligo/LexToken.mli b/src/passes/1-parser/reasonligo/LexToken.mli index 47f012427..3c8aadb96 100644 --- a/src/passes/1-parser/reasonligo/LexToken.mli +++ b/src/passes/1-parser/reasonligo/LexToken.mli @@ -87,6 +87,7 @@ type t = | Mutez of (string * Z.t) Region.reg | String of string Region.reg | Bytes of (string * Hex.t) Region.reg +| Attr of string Region.reg (* Keywords *) @@ -135,12 +136,15 @@ type ident_err = Reserved_name type nat_err = Invalid_natural | Non_canonical_zero_nat type sym_err = Invalid_symbol +type attr_err = Invalid_attribute type kwd_err = Invalid_keyword val mk_int : lexeme -> Region.t -> (token, int_err) result val mk_nat : lexeme -> Region.t -> (token, nat_err) result val mk_mutez : lexeme -> Region.t -> (token, int_err) result val mk_ident : lexeme -> Region.t -> (token, ident_err) result +val mk_attr : lexeme -> Region.t -> (token, attr_err) result +val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result val mk_sym : lexeme -> Region.t -> (token, sym_err) result val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result val mk_string : lexeme -> Region.t -> token diff --git a/src/passes/1-parser/reasonligo/LexToken.mll b/src/passes/1-parser/reasonligo/LexToken.mll index 341dd8015..8949dc64f 100644 --- a/src/passes/1-parser/reasonligo/LexToken.mll +++ b/src/passes/1-parser/reasonligo/LexToken.mll @@ -71,6 +71,7 @@ type t = | Mutez of (string * Z.t) Region.reg | String of string Region.reg | Bytes of (string * Hex.t) Region.reg +| Attr of string Region.reg (* Keywords *) @@ -153,6 +154,7 @@ let proj_token = function | Type region -> region, "Type" | C_None region -> region, "C_None" | C_Some region -> region, "C_Some" +| Attr Region.{region; value} -> region, sprintf "Attr %s" value | EOF region -> region, "EOF" let to_lexeme = function @@ -203,6 +205,7 @@ let to_lexeme = function | Type _ -> "type" | C_None _ -> "None" | C_Some _ -> "Some" +| Attr a -> a.Region.value | EOF _ -> "" let to_string token ?(offsets=true) mode = @@ -219,6 +222,7 @@ type ident_err = Reserved_name type nat_err = Invalid_natural | Non_canonical_zero_nat type sym_err = Invalid_symbol +type attr_err = Invalid_attribute type kwd_err = Invalid_keyword (* LEXIS *) @@ -447,6 +451,14 @@ let mk_constr' lexeme region lexicon = let mk_constr lexeme region = mk_constr' lexeme region lexicon +(* Attributes *) + +let mk_attr lexeme region = + Ok (Attr { value = lexeme; region }) + +let mk_attr2 _lexeme _region = + Error Invalid_attribute + (* Predicates *) let is_string = function diff --git a/src/passes/1-parser/reasonligo/ParToken.mly b/src/passes/1-parser/reasonligo/ParToken.mly index 4a94ddb6b..b19effeca 100644 --- a/src/passes/1-parser/reasonligo/ParToken.mly +++ b/src/passes/1-parser/reasonligo/ParToken.mly @@ -12,6 +12,7 @@ %token <(string * Z.t) Region.reg> Mutez "" %token Ident "" %token Constr "" +%token Attr "" (* Symbols *) diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index 051880a3b..9bfb5e76a 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -230,12 +230,13 @@ field_decl: (* Top-level non-recursive definitions *) let_declaration: - "let" let_binding { - let kwd_let = $1 in - let binding = $2 in - let value = kwd_let, binding in + seq(Attr) "let" let_binding { + let attributes = $1 in + let kwd_let = $2 in + let binding = $3 in + let value = kwd_let, binding, attributes in let stop = expr_to_region binding.let_rhs in - let region = cover $1 stop + let region = cover $2 stop in {region; value} } es6_func: @@ -416,6 +417,7 @@ type_expr_simple: type_annotation_simple: ":" type_expr_simple { $1,$2 } + fun_expr: disj_expr_level es6_func { let arrow, body = $2 in @@ -476,7 +478,8 @@ fun_expr: binders; lhs_type=None; arrow; - body} + body + } in EFun {region; value=f} } base_expr(right_expr): @@ -558,14 +561,15 @@ case_clause(right_expr): in {region; value} } let_expr(right_expr): - "let" let_binding ";" right_expr { - let kwd_let = $1 in - let binding = $2 in - let kwd_in = $3 in - let body = $4 in - let stop = expr_to_region $4 in - let region = cover $1 stop - and value = {kwd_let; binding; kwd_in; body} + seq(Attr) "let" let_binding ";" right_expr { + let attributes = $1 in + let kwd_let = $2 in + let binding = $3 in + let kwd_in = $4 in + let body = $5 in + let stop = expr_to_region $5 in + let region = cover $2 stop + and value = {kwd_let; binding; kwd_in; body; attributes} in ELetIn {region; value} } disj_expr_level: diff --git a/src/passes/1-parser/shared/Lexer.mli b/src/passes/1-parser/shared/Lexer.mli index ddfda545a..d01c5387f 100644 --- a/src/passes/1-parser/shared/Lexer.mli +++ b/src/passes/1-parser/shared/Lexer.mli @@ -65,6 +65,7 @@ module type TOKEN = type nat_err = Invalid_natural | Non_canonical_zero_nat type sym_err = Invalid_symbol + type attr_err = Invalid_attribute (* Injections *) @@ -76,6 +77,8 @@ module type TOKEN = val mk_string : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token + val mk_attr : lexeme -> Region.t -> (token, attr_err) result + val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result val eof : Region.t -> token (* Predicates *) diff --git a/src/passes/1-parser/shared/Lexer.mll b/src/passes/1-parser/shared/Lexer.mll index 6115e62fb..ce8c454fb 100644 --- a/src/passes/1-parser/shared/Lexer.mll +++ b/src/passes/1-parser/shared/Lexer.mll @@ -107,6 +107,7 @@ module type TOKEN = type nat_err = Invalid_natural | Non_canonical_zero_nat type sym_err = Invalid_symbol + type attr_err = Invalid_attribute (* Injections *) @@ -118,6 +119,8 @@ module type TOKEN = val mk_string : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token val mk_constr : lexeme -> Region.t -> token + val mk_attr : lexeme -> Region.t -> (token, attr_err) result + val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result val eof : Region.t -> token (* Predicates *) @@ -385,6 +388,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) = | Reserved_name of string | Invalid_symbol | Invalid_natural + | Invalid_attribute let error_to_string = function Invalid_utf8_sequence -> @@ -432,6 +436,8 @@ module Make (Token: TOKEN) : (S with module Token = Token) = Hint: Check the LIGO syntax you use.\n" | Invalid_natural -> "Invalid natural." + | Invalid_attribute -> + "Invalid attribute." exception Error of error Region.reg @@ -525,6 +531,22 @@ module Make (Token: TOKEN) : (S with module Token = Token) = Ok token -> token, state | Error Token.Reserved_name -> fail region (Reserved_name lexeme) + let mk_attr state buffer attr = + let region, _, state = sync state buffer in + match Token.mk_attr attr region with + Ok token -> + token, state + | Error Token.Invalid_attribute -> + fail region Invalid_attribute + + let mk_attr2 state buffer attr = + let region, _, state = sync state buffer in + match Token.mk_attr2 attr region with + Ok token -> + token, state + | Error Token.Invalid_attribute -> + fail region Invalid_attribute + let mk_constr state buffer = let region, lexeme, state = sync state buffer in Token.mk_constr lexeme region, state @@ -538,6 +560,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) = let mk_eof state buffer = let region, _, state = sync state buffer in Token.eof region, state + (* END HEADER *) } @@ -564,8 +587,8 @@ let bytes = "0x" (byte_seq? as seq) let esc = "\\n" | "\\\"" | "\\\\" | "\\b" | "\\r" | "\\t" | "\\x" byte let pascaligo_sym = "=/=" | '#' | ":=" -let cameligo_sym = "<>" | "::" | "||" | "&&" -let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&" +let cameligo_sym = "<>" | "::" | "||" | "&&" | "[@" +let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&" | "[@" let symbol = ';' | ',' | '(' | ')'| '[' | ']' | '{' | '}' @@ -604,7 +627,8 @@ and scan state = parse | natural { mk_int state lexbuf |> enqueue } | symbol { mk_sym state lexbuf |> enqueue } | eof { mk_eof state lexbuf |> enqueue } - +| "[@" (ident|constr as attr) "]" { mk_attr state lexbuf attr |> enqueue } +| "[@@" (ident|constr as attr) "]" { mk_attr2 state lexbuf attr |> enqueue } | '"' { let opening, _, state = sync state lexbuf in let thread = {opening; len=1; acc=['"']} in scan_string thread state lexbuf |> mk_string |> enqueue } diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index c2eb0270b..fb16694fb 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -300,10 +300,10 @@ let rec simpl_expression : trace (simplifying_expr t) @@ match t with Raw.ELetIn e -> - let Raw.{binding; body; _} = e.value in + let Raw.{binding; body; attributes; _} = e.value in + let inline = List.exists (fun (a: Raw.attribute) -> a.value = "inline") attributes in let Raw.{binders; lhs_type; let_rhs; _} = binding in begin match binders with - (* let p = rhs in body *) | (p, []) -> let%bind variables = tuple_pattern_to_typed_vars p in let%bind ty_opt = @@ -338,18 +338,19 @@ let rec simpl_expression : match variables with | hd :: [] -> if (List.length prep_vars = 1) - then e_let_in hd rhs_b_expr body - else e_let_in hd (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - 1)]) body + then e_let_in hd inline rhs_b_expr body + else e_let_in hd inline (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - 1)]) body | hd :: tl -> e_let_in hd - (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)]) + inline + (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)]) (chain_let_in tl body) | [] -> body (* Precluded by corner case assertion above *) in if List.length prep_vars = 1 then ok (chain_let_in prep_vars body) (* Bind the right hand side so we only evaluate it once *) - else ok (e_let_in (rhs_b, ty_opt) rhs' (chain_let_in prep_vars body)) + else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body)) (* let f p1 ps... = rhs in body *) | (f, p1 :: ps) -> @@ -486,7 +487,7 @@ let rec simpl_expression : | Raw.PVar y -> let var_name = Var.of_name y.value in let%bind type_expr = simpl_type_expression x'.type_expr in - return @@ e_let_in (var_name , Some type_expr) e rhs + return @@ e_let_in (var_name , Some type_expr) false e rhs | _ -> default_action () ) | _ -> default_action () @@ -597,6 +598,7 @@ and simpl_fun lamb' : expr result = binding= let_in_binding; kwd_in= Region.ghost; body= lamb.body; + attributes = [] } in ok (Raw.ELetIn @@ -701,8 +703,9 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result let%bind type_expression = simpl_type_expression type_expr in ok @@ [loc x @@ Declaration_type (Var.of_name name.value , type_expression)] | Let x -> ( - let binding, _ = r_split x in - let binding = snd binding in + let (_, let_binding, attributes), _ = r_split x in + let inline = List.exists (fun (a: Raw.attribute) -> a.value = "inline") attributes in + let binding = let_binding in let {binders; lhs_type; let_rhs} = binding in let%bind (hd, _) = let (hd, tl) = binders in ok (hd, tl) in @@ -716,9 +719,9 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result match v_type with | Some v_type -> ok (to_option (simpl_type_expression v_type)) | None -> ok None - in + in let%bind simpl_rhs_expr = simpl_expression rhs_expr in - ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, simpl_rhs_expr) ) + ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, simpl_rhs_expr) ) in let%bind variables = ok @@ npseq_to_list pt.value in let%bind expr_bind_lst = match let_rhs with @@ -757,14 +760,14 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result in ok @@ decls | PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } -> (* Extract parenthetical multi-bind *) - let wild = fst @@ fst @@ r_split x in + let (wild, _, attributes) = fst @@ r_split x in simpl_declaration (Let { region = x.region; value = (wild, {binders = (pt, []); lhs_type = lhs_type; eq = Region.ghost ; - let_rhs = let_rhs})} + let_rhs = let_rhs}, attributes)} : Raw.declaration) | _ -> let%bind (var, args) = @@ -778,17 +781,18 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result let%bind lhs_type' = bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in let%bind rhs' = simpl_expression let_rhs in - ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type' , rhs'))] + ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type' , inline, rhs'))] | param1::others -> let fun_ = { kwd_fun = Region.ghost; binders = param1, others; lhs_type; arrow = Region.ghost; - body = let_rhs} in + body = let_rhs + } in let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in let%bind rhs' = simpl_expression rhs in - ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , None , rhs'))] + ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , None , inline, rhs'))] ) and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 5c6fdf8a7..afcab47ce 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -195,10 +195,10 @@ let r_split = Location.r_split [return_statement] is used for non-let-in statements. *) -let return_let_in ?loc binder rhs = ok @@ fun expr'_opt -> +let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt -> match expr'_opt with | None -> fail @@ corner_case ~loc:__LOC__ "missing return" - | Some expr' -> ok @@ e_let_in ?loc binder rhs expr' + | Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr' let return_statement expr = ok @@ fun expr'_opt -> match expr'_opt with @@ -573,17 +573,19 @@ and simpl_data_declaration : Raw.data_decl -> _ result = fun t -> let name = x.name.value in let%bind t = simpl_type_expression x.var_type in let%bind expression = simpl_expression x.init in - return_let_in ~loc (Var.of_name name , Some t) expression + return_let_in ~loc (Var.of_name name , Some t) false expression | LocalConst x -> let (x , loc) = r_split x in let name = x.name.value in let%bind t = simpl_type_expression x.const_type in let%bind expression = simpl_expression x.init in - return_let_in ~loc (Var.of_name name , Some t) expression + let inline = List.exists (fun (f: Raw.attribute) -> f.value = "\"inline\"") x.attributes.value in + return_let_in ~loc (Var.of_name name , Some t) inline expression | LocalFun f -> let (f , loc) = r_split f in - let%bind (binder, expr) = simpl_fun_decl ~loc f - in return_let_in ~loc binder expr + let%bind (binder, expr) = simpl_fun_decl ~loc f in + let inline = List.exists (fun (f: Raw.attribute) -> f.value = "\"inline\"") f.attributes.value in + return_let_in ~loc binder inline expr and simpl_param : Raw.param_decl -> (expression_variable * type_expression) result = fun t -> @@ -603,7 +605,8 @@ and simpl_fun_decl : loc:_ -> Raw.fun_decl -> ((expression_variable * type_expression option) * expression) result = fun ~loc x -> let open! Raw in - let {fun_name;param;ret_type;block_with;return} : fun_decl = x in + let {fun_name;param;ret_type;block_with;return; attributes} : fun_decl = x in + let inline = List.exists (fun (a: Raw.attribute) -> a.value = "\"inline\"") attributes.value in let statements = match block_with with | Some (block,_) -> npseq_to_list block.value.statements @@ -641,7 +644,7 @@ and simpl_fun_decl : let expr = e_accessor (e_variable arguments_name) [Access_tuple i] in let type_variable = Some (snd x) in - let ass = return_let_in (fst x , type_variable) expr in + let ass = return_let_in (fst x , type_variable) inline expr in ass in bind_list @@ List.mapi aux params in @@ -699,7 +702,7 @@ and simpl_fun_expression : let expr = e_accessor (e_variable arguments_name) [Access_tuple i] in let type_variable = Some (snd x) in - let ass = return_let_in (fst x , type_variable) expr in + let ass = return_let_in (fst x , type_variable) false expr in ass in bind_list @@ List.mapi aux params in @@ -731,17 +734,19 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = (Var.of_name name.value, type_expression)) | ConstDecl x -> - let simpl_const_decl = fun {name;const_type;init} -> + let simpl_const_decl = fun {name;const_type; init; attributes} -> let%bind expression = simpl_expression init in let%bind t = simpl_type_expression const_type in let type_annotation = Some t in + let inline = List.exists (fun (a: Raw.attribute) -> a.value = "\"inline\"") attributes.value in ok @@ Declaration_constant - (Var.of_name name.value, type_annotation, expression) + (Var.of_name name.value, type_annotation, inline, expression) in bind_map_location simpl_const_decl (Location.lift_region x) | FunDecl x -> let decl, loc = r_split x in let%bind ((name, ty_opt), expr) = simpl_fun_decl ~loc decl in - ok @@ Location.wrap ~loc (Declaration_constant (name, ty_opt, expr)) + let inline = List.exists (fun (a: Raw.attribute) -> a.value = "\"inline\"") x.value.attributes.value in + ok @@ Location.wrap ~loc (Declaration_constant (name, ty_opt, inline, expr)) and simpl_statement : Raw.statement -> (_ -> expression result) result = fun s -> @@ -1103,7 +1108,7 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> | _ -> e_sequence body ctrl in let body' = add_to_seq body in let loop = e_loop comp body' in - return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) value loop + return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) false value loop (** simpl_for_collect For loops over collections, like @@ -1269,14 +1274,14 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun let acc = arg_access [Access_tuple 0 ] in let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in let collec_elt_k = arg_access [Access_tuple 1 ; Access_tuple 1] in - e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *) - e_let_in (Var.of_name elt_name, None) collec_elt_v @@ - e_let_in (Var.of_name elt_v_name, None) collec_elt_k (for_body) + e_let_in (Var.of_name "#COMPILER#acc", None) false acc @@ (* TODO fresh *) + e_let_in (Var.of_name elt_name, None) false collec_elt_v @@ + e_let_in (Var.of_name elt_v_name, None) false collec_elt_k (for_body) | _ -> let acc = arg_access [Access_tuple 0] in let collec_elt = arg_access [Access_tuple 1] in - e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *) - e_let_in (Var.of_name elt_name, None) collec_elt (for_body) + e_let_in (Var.of_name "#COMPILER#acc", None) false acc @@ (* TODO fresh *) + e_let_in (Var.of_name elt_name, None) false collec_elt (for_body) ) in (* STEP 7 *) let%bind collect = simpl_expression fc.expr in @@ -1297,7 +1302,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun let final_sequence = match reassign_sequence with (* None case means that no variables were captured *) | None -> e_skip () - | Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) fold seq in (* TODO fresh *) + | Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) false fold seq in (* TODO fresh *) return_statement @@ final_sequence let simpl_program : Raw.ast -> program result = fun t -> diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_simplified/helpers.ml index f57fb256b..fc4346147 100644 --- a/src/passes/3-self_ast_simplified/helpers.ml +++ b/src/passes/3-self_ast_simplified/helpers.ml @@ -157,10 +157,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind ab' = bind_map_pair self ab in return @@ E_application ab' ) - | E_let_in { binder ; rhs ; result } -> ( + | E_let_in { binder ; rhs ; result; inline } -> ( let%bind rhs = self rhs in let%bind result = self result in - return @@ E_let_in { binder ; rhs ; result } + return @@ E_let_in { binder ; rhs ; result; inline } ) | E_lambda { binder ; input_type ; output_type ; result } -> ( let%bind result = self result in @@ -206,9 +206,9 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> and map_program : mapper -> program -> program result = fun m p -> let aux = fun (x : declaration) -> match x with - | Declaration_constant (t , o , e) -> ( + | Declaration_constant (t , o , i, e) -> ( let%bind e' = map_expression m e in - ok (Declaration_constant (t , o , e')) + ok (Declaration_constant (t , o , i, e')) ) | Declaration_type _ -> ok x in diff --git a/src/passes/4-typer-new/typer.ml b/src/passes/4-typer-new/typer.ml index da0543b74..5d1d68465 100644 --- a/src/passes/4-typer-new/typer.ml +++ b/src/passes/4-typer-new/typer.ml @@ -218,7 +218,7 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat let%bind tv = evaluate_type env type_expression in let env' = Environment.add_type type_name tv env in ok (env', state , None) - | Declaration_constant (name , tv_opt , expression) -> ( + | Declaration_constant (name , tv_opt , inline, expression) -> ( (* Determine the type of the expression and add it to the environment *) @@ -227,7 +227,7 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat trace (constant_declaration_error name expression tv'_opt) @@ type_expression env state expression in let env' = Environment.add_ez_ae name ae' env in - ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) + ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , inline, (env , env')))) ) and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.matching -> I.expression -> Location.t -> ((O.value, O.type_value) O.matching * Solver.state) result = @@ -781,7 +781,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e let%bind (body' , state'') = type_expression e state' body in let wrapped = Wrap.loop expr'.type_annotation body'.type_annotation in return_wrapped (O.E_loop (expr' , body')) state'' wrapped - | E_let_in {binder ; rhs ; result} -> + | E_let_in {binder ; rhs ; result ; inline} -> let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in (* TODO: the binder annotation should just be an annotation node *) let%bind (rhs , state') = type_expression e state rhs in @@ -789,7 +789,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e let%bind (result , state'') = type_expression e' state' result in let wrapped = Wrap.let_in rhs.type_annotation rhs_tv_opt result.type_annotation in - return_wrapped (E_let_in {binder = fst binder; rhs; result}) state'' wrapped + return_wrapped (E_let_in {binder = fst binder; rhs; result; inline}) state'' wrapped | E_assign (name , path , expr) -> let%bind typed_name = let%bind ele = Environment.get_trace name e in @@ -1143,11 +1143,11 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = | E_sequence _ | E_loop _ | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression - | E_let_in {binder; rhs;result} -> + | E_let_in {binder; rhs; result; inline} -> let%bind tv = untype_type_value rhs.type_annotation in let%bind rhs = untype_expression rhs in let%bind result = untype_expression result in - return (e_let_in (binder , (Some tv)) rhs result) + return (e_let_in (binder , (Some tv)) inline rhs result) (* Tranform a Ast_typed matching into an ast_simplified matching diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index 59cbbf8bc..1b9f90fbd 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -218,13 +218,13 @@ and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) : let%bind tv = evaluate_type env type_expression in let env' = Environment.add_type type_name tv env in ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None) - | Declaration_constant (name , tv_opt , expression) -> ( + | Declaration_constant (name , tv_opt , inline, expression) -> ( let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind ae' = trace (constant_declaration_error name expression tv'_opt) @@ type_expression' ?tv_opt:tv'_opt env expression in let env' = Environment.add_ez_ae name ae' env in - ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) + ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant ((make_n_e name ae') , inline, (env , env')))) ) and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> (i, unit) I.matching -> I.expression -> Location.t -> (o, O.type_value) O.matching result = @@ -805,12 +805,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O. expr'.location) @@ Ast_typed.assert_type_value_eq (assign_tv , t_expr') in return (O.E_assign (typed_name , path' , expr')) (t_unit ()) - | E_let_in {binder ; rhs ; result} -> + | E_let_in {binder ; rhs ; result; inline} -> let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in let%bind rhs = type_expression' ?tv_opt:rhs_tv_opt e rhs in let e' = Environment.add_ez_declaration (fst binder) rhs e in let%bind result = type_expression' e' result in - return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation + return (E_let_in {binder = fst binder; rhs; result; inline}) result.type_annotation | E_ascription (expr , te) -> let%bind tv = evaluate_type e te in let%bind expr' = type_expression' ~tv_opt:tv e expr in @@ -926,11 +926,11 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = | E_sequence _ | E_loop _ | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression - | E_let_in {binder;rhs;result} -> + | E_let_in {binder; rhs; result; inline} -> let%bind tv = untype_type_value rhs.type_annotation in let%bind rhs = untype_expression rhs in let%bind result = untype_expression result in - return (e_let_in (binder , (Some tv)) rhs result) + return (e_let_in (binder , (Some tv)) inline rhs result) and untype_matching : type o i . (o -> i result) -> (o,O.type_value) O.matching -> ((i,unit) I.matching) result = fun f m -> let open I in diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 36637aca2..0cde2e3b5 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -258,10 +258,10 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re info title content in trace info @@ match ae.expression with - | E_let_in {binder; rhs; result} -> + | E_let_in {binder; rhs; result; inline} -> let%bind rhs' = transpile_annotated_expression rhs in let%bind result' = transpile_annotated_expression result in - return (E_let_in ((binder, rhs'.type_value), rhs', result')) + return (E_let_in ((binder, rhs'.type_value), inline, rhs', result')) | E_literal l -> return @@ E_literal (transpile_literal l) | E_variable name -> ( let%bind ele = @@ -587,7 +587,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re trace_option (corner_case ~loc:__LOC__ "missing match clause") @@ List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in let%bind body' = transpile_annotated_expression body in - return @@ E_let_in ((name , tv) , top , body') + return @@ E_let_in ((name , tv) , false , top , body') ) | ((`Node (a , b)) , tv) -> let%bind a' = @@ -621,11 +621,11 @@ and transpile_lambda l (input_type , output_type) = let transpile_declaration env (d:AST.declaration) : toplevel_statement result = match d with - | Declaration_constant ({name;annotated_expression} , _) -> + | Declaration_constant ({name;annotated_expression} , inline , _) -> let%bind expression = transpile_annotated_expression annotated_expression in let tv = Combinators.Expression.get_type expression in let env' = Environment.add (name, tv) env in - ok @@ ((name, expression), environment_wrap env env') + ok @@ ((name, inline, expression), environment_wrap env env') let transpile_program (lst : AST.program) : program result = let aux (prev:(toplevel_statement list * Environment.t) result) cur = diff --git a/src/passes/7-self_mini_c/helpers.ml b/src/passes/7-self_mini_c/helpers.ml index 4c8af0d33..ea7756a35 100644 --- a/src/passes/7-self_mini_c/helpers.ml +++ b/src/passes/7-self_mini_c/helpers.ml @@ -72,7 +72,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = bind_fold_triple self init' (c,l,r) in ok res ) - | E_let_in ((_, _) , expr , body) -> ( + | E_let_in ((_, _) , _inline, expr , body) -> ( let%bind res = bind_fold_pair self init' (expr,body) in ok res ) @@ -146,9 +146,9 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind (c',l',r') = bind_map_triple self (c,l,r) in return @@ E_if_left (c', ((name_l, tvl) , l'), ((name_r, tvr) , r')) ) - | E_let_in ((v , tv) , expr , body) -> ( + | E_let_in ((v , tv) , inline, expr , body) -> ( let%bind (expr',body') = bind_map_pair self (expr,body) in - return @@ E_let_in ((v , tv) , expr' , body') + return @@ E_let_in ((v , tv) , inline , expr' , body') ) | E_sequence ab -> ( let%bind ab' = bind_map_pair self ab in diff --git a/src/passes/7-self_mini_c/self_mini_c.ml b/src/passes/7-self_mini_c/self_mini_c.ml index f0c370d05..329dad692 100644 --- a/src/passes/7-self_mini_c/self_mini_c.ml +++ b/src/passes/7-self_mini_c/self_mini_c.ml @@ -60,7 +60,7 @@ let rec is_pure : expression -> bool = fun e -> | E_if_left (cond, (_, bt), (_, bf)) -> List.for_all is_pure [ cond ; bt ; bf ] - | E_let_in (_, e1, e2) + | E_let_in (_, _, e1, e2) | E_sequence (e1, e2) -> List.for_all is_pure [ e1 ; e2 ] @@ -133,7 +133,7 @@ let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression - selfs [ e1 ; e2 ] || self_binder2 hd tl e3 | E_if_left (e1, ((l, _), e2), ((r, _), e3)) -> self e1 || self_binder l e2 || self_binder r e3 - | E_let_in ((x, _), e1, e2) -> + | E_let_in ((x, _), _, e1, e2) -> self e1 || self_binder x e2 | E_sequence (e1, e2) -> selfs [ e1 ; e2 ] @@ -188,8 +188,8 @@ let should_inline : expression_variable -> expression -> bool = let inline_let : bool ref -> expression -> expression = fun changed e -> match e.content with - | E_let_in ((x, _a), e1, e2) -> - if can_inline x e1 e2 && should_inline x e2 + | E_let_in ((x, _a), should_inline_here, e1, e2) -> + if can_inline x e1 e2 && (should_inline_here || should_inline x e2) then (* can raise Subst.Bad_argument, but should not happen, due to can_inline *) @@ -232,7 +232,7 @@ let beta : bool ref -> expression -> expression = if can_beta { binder = x ; body = e1 } then (changed := true ; - Expression.make (E_let_in ((x, xtv), e2, e1)) tv) + Expression.make (E_let_in ((x, xtv), false, e2, e1)) tv) else e (* also do CAR (PAIR x y) ↦ x, or CDR (PAIR x y) ↦ y, only if x and y are pure *) diff --git a/src/passes/7-self_mini_c/subst.ml b/src/passes/7-self_mini_c/subst.ml index be4924c01..ddba8855a 100644 --- a/src/passes/7-self_mini_c/subst.ml +++ b/src/passes/7-self_mini_c/subst.ml @@ -81,11 +81,11 @@ let rec replace : expression -> var_name -> var_name -> expression = let v2 = replace_var v2 in let bt = replace bt in return @@ E_if_left (c, ((v1, tv1), bt), ((v2, tv2), bf)) - | E_let_in ((v, tv), e1, e2) -> + | E_let_in ((v, tv), inline, e1, e2) -> let v = replace_var v in let e1 = replace e1 in let e2 = replace e2 in - return @@ E_let_in ((v, tv), e1, e2) + return @@ E_let_in ((v, tv), inline, e1, e2) | E_sequence (e1, e2) -> let e1 = replace e1 in let e2 = replace e2 in @@ -144,10 +144,10 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e let (binder, body) = subst_binder binder body in return @@ E_closure { binder ; body } ) - | E_let_in ((v , tv) , expr , body) -> ( + | E_let_in ((v , tv) , inline, expr , body) -> ( let expr = self expr in let (v, body) = subst_binder v body in - return @@ E_let_in ((v , tv) , expr , body) + return @@ E_let_in ((v , tv) , inline, expr , body) ) | E_iterator (s, ((name , tv) , body) , collection) -> ( let (name, body) = subst_binder name body in @@ -292,7 +292,7 @@ let%expect_test _ = (* let-in shadowed (not in rhs) *) Var.reset_counter () ; show_subst - ~body:(wrap (E_let_in ((x, dummy_type), var x, var x))) + ~body:(wrap (E_let_in ((x, dummy_type), false, var x, var x))) ~x:x ~expr:unit ; [%expect{| @@ -303,7 +303,7 @@ let%expect_test _ = (* let-in not shadowed *) Var.reset_counter () ; show_subst - ~body:(wrap (E_let_in ((y, dummy_type), var x, var x))) + ~body:(wrap (E_let_in ((y, dummy_type), false, var x, var x))) ~x:x ~expr:unit ; [%expect{| @@ -314,7 +314,7 @@ let%expect_test _ = (* let-in capture avoidance *) Var.reset_counter () ; show_subst - ~body:(wrap (E_let_in ((y, dummy_type), var x, + ~body:(wrap (E_let_in ((y, dummy_type), false, var x, app (var x) (var y)))) ~x:x ~expr:(var y) ; diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 339e3aa85..280d93cfd 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -316,7 +316,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result ]) in return code ) - | E_let_in (v , expr , body) -> ( + | E_let_in (v , _, expr , body) -> ( let%bind expr' = translate_expression expr env in let%bind body' = translate_expression body (Environment.add v env) in let%bind code = ok (seq [ diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml index 2cedff888..768d6d12a 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/ast_simplified/PP.ml @@ -52,8 +52,8 @@ let rec expression ppf (e:expression) = match e.expression with name n PP_helpers.(list_sep access (const ".")) path expression expr - | E_let_in { binder ; rhs ; result } -> - fprintf ppf "let %a = %a in %a" option_type_name binder expression rhs expression result + | E_let_in { binder ; rhs ; result; inline } -> + fprintf ppf "let %a = %a%a in %a" option_type_name binder expression rhs option_inline inline expression result | E_skip -> fprintf ppf "skip" | E_ascription (expr , ty) -> fprintf ppf "%a : %a" expression expr type_expression ty @@ -62,6 +62,12 @@ and option_type_name ppf ((n , ty_opt) : expression_variable * type_expression o | None -> fprintf ppf "%a" name n | Some ty -> fprintf ppf "%a : %a" name n type_expression ty +and option_inline ppf inline = + if inline then + fprintf ppf "[@inline]" + else + fprintf ppf "" + and assoc_expression ppf : (expr * expr) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b @@ -119,8 +125,8 @@ and matching_variant_case_type ppf ((c,n),_a) = let declaration ppf (d:declaration) = match d with | Declaration_type (type_name , te) -> fprintf ppf "type %a = %a" type_variable (type_name) type_expression te - | Declaration_constant (name , ty_opt , expr) -> - fprintf ppf "const %a = %a" option_type_name (name , ty_opt) expression expr + | Declaration_constant (name , ty_opt , inline, expr) -> + fprintf ppf "const %a = %a%a" option_type_name (name , ty_opt) expression expr option_inline inline let program ppf (p:program) = fprintf ppf "@[%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml index d8d6c3ebf..1077f991a 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/ast_simplified/combinators.ml @@ -117,7 +117,7 @@ let e_variable ?loc v = location_wrap ?loc @@ E_variable v let e_skip ?loc () = location_wrap ?loc @@ E_skip let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body) let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b) -let e_let_in ?loc (binder, ascr) rhs result = location_wrap ?loc @@ E_let_in { binder = (binder, ascr) ; rhs ; result } +let e_let_in ?loc (binder, ascr) inline rhs result = location_wrap ?loc @@ E_let_in { binder = (binder, ascr) ; rhs ; result ; inline } let e_annotation ?loc expr ty = location_wrap ?loc @@ E_ascription (expr , ty) let e_application ?loc a b = location_wrap ?loc @@ E_application (a , b) let e_binop ?loc name a b = location_wrap ?loc @@ E_constant (name , [a ; b]) diff --git a/src/stages/ast_simplified/combinators.mli b/src/stages/ast_simplified/combinators.mli index 760eb59b5..376ec322e 100644 --- a/src/stages/ast_simplified/combinators.mli +++ b/src/stages/ast_simplified/combinators.mli @@ -84,7 +84,7 @@ val e_variable : ?loc:Location.t -> expression_variable -> expression val e_skip : ?loc:Location.t -> unit -> expression val e_loop : ?loc:Location.t -> expression -> expression -> expression val e_sequence : ?loc:Location.t -> expression -> expression -> expression -val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> expression -> expression -> expression +val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> inline -> expression -> expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression val e_application : ?loc:Location.t -> expression -> expression -> expression val e_binop : ?loc:Location.t -> constant -> expression -> expression -> expression diff --git a/src/stages/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml index 7e73908f8..3be7b3fb8 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/ast_simplified/types.ml @@ -4,12 +4,14 @@ include Stage_common.Types type program = declaration Location.wrap list +and inline = bool + and type_expression = { type_expression' : type_expression type_expression' } and declaration = | Declaration_type of (type_variable * type_expression) - | Declaration_constant of (expression_variable * type_expression option * expression) + | Declaration_constant of (expression_variable * type_expression option * inline * expression) (* | Macro_declaration of macro_declaration *) and expr = expression @@ -22,9 +24,10 @@ and lambda = { } and let_in = { - binder : (expression_variable * type_expression option) ; - rhs : expr ; - result : expr ; + binder : (expression_variable * type_expression option) ; + rhs : expr ; + result : expr ; + inline : inline; } and expression' = diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 985f05dd1..3fc3c2483 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -24,6 +24,12 @@ and lambda ppf l = name binder annotated_expression body +and option_inline ppf inline = + if inline then + fprintf ppf "[@inline]" + else + fprintf ppf "" + and expression ppf (e:expression) : unit = match e with | E_literal l -> Stage_common.PP.literal ppf l @@ -51,7 +57,8 @@ and expression ppf (e:expression) : unit = Stage_common.PP.name name.type_name PP_helpers.(list_sep pre_access (const ".")) path annotated_expression expr - | E_let_in { binder; rhs; result } -> fprintf ppf "let %a = %a in %a" name binder annotated_expression rhs annotated_expression result + | E_let_in { binder; rhs; result; inline } -> + fprintf ppf "let %a = %a%a in %a" name binder annotated_expression rhs option_inline inline annotated_expression result and value ppf v = annotated_expression ppf v @@ -83,8 +90,8 @@ and pre_access ppf (a:access) = match a with let declaration ppf (d:declaration) = match d with - | Declaration_constant ({name ; annotated_expression = ae} , _) -> - fprintf ppf "const %a = %a" Stage_common.PP.name name annotated_expression ae + | Declaration_constant ({name ; annotated_expression = ae} , inline, _) -> + fprintf ppf "const %a = %a%a" Stage_common.PP.name name annotated_expression ae option_inline inline let program ppf (p:program) = fprintf ppf "@[%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 42ce3118a..8ebe2b89d 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -276,7 +276,7 @@ let e_pair a b : expression = E_tuple [a; b] let e_application a b : expression = E_application (a , b) let e_variable v : expression = E_variable v let e_list lst : expression = E_list lst -let e_let_in binder rhs result = E_let_in { binder ; rhs ; result } +let e_let_in binder inline rhs result = E_let_in { binder ; rhs ; result; inline } let e_tuple lst : expression = E_tuple lst let e_a_unit = make_a_e e_unit (t_unit ()) @@ -297,7 +297,7 @@ let e_a_variable v ty = make_a_e (e_variable v) ty let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ()) let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ()) let e_a_list lst t = make_a_e (e_list lst) (t_list t ()) -let e_a_let_in binder expr body = make_a_e (e_let_in binder expr body) (get_type_annotation body) +let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_annotation body) let get_a_int (t:annotated_expression) = match t.expression with @@ -323,7 +323,7 @@ let get_a_record_accessor = fun t -> let get_declaration_by_name : program -> string -> declaration result = fun p name -> let aux : declaration -> bool = fun declaration -> match declaration with - | Declaration_constant (d , _) -> d.name = Var.of_name name + | Declaration_constant (d , _, _) -> d.name = Var.of_name name in trace_option (Errors.declaration_not_found name ()) @@ List.find_opt aux @@ List.map Location.unwrap p diff --git a/src/stages/ast_typed/combinators.mli b/src/stages/ast_typed/combinators.mli index 5b558b849..f9cd7d93d 100644 --- a/src/stages/ast_typed/combinators.mli +++ b/src/stages/ast_typed/combinators.mli @@ -132,7 +132,7 @@ val e_pair : value -> value -> expression val e_application : value -> value -> expression val e_variable : expression_variable -> expression val e_list : value list -> expression -val e_let_in : expression_variable -> value -> value -> expression +val e_let_in : expression_variable -> inline -> value -> value -> expression val e_tuple : value list -> expression val e_a_unit : full_environment -> annotated_expression @@ -153,7 +153,7 @@ val e_a_variable : expression_variable -> type_value -> full_environment -> anno val ez_e_a_record : ( label * annotated_expression ) list -> full_environment -> annotated_expression val e_a_map : ( annotated_expression * annotated_expression ) list -> type_value -> type_value -> full_environment -> annotated_expression val e_a_list : annotated_expression list -> type_value -> full_environment -> annotated_expression -val e_a_let_in : expression_variable -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression +val e_a_let_in : expression_variable -> inline -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression val get_a_int : annotated_expression -> int result val get_a_unit : annotated_expression -> unit result diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 1d46a6bb6..6ece0d8ab 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -188,7 +188,7 @@ module Free_variables = struct | E_sequence (a , b) -> unions @@ List.map self [ a ; b ] | E_loop (expr , body) -> unions @@ List.map self [ expr ; body ] | E_assign (_ , _ , expr) -> self expr - | E_let_in { binder; rhs; result } -> + | E_let_in { binder; rhs; result; _ } -> let b' = union (singleton binder) b in union (annotated_expression b' result) @@ -529,7 +529,7 @@ let merge_annotation (a:type_value option) (b:type_value option) err : type_valu let get_entry (lst : program) (name : string) : annotated_expression result = trace_option (Errors.missing_entry_point name) @@ let aux x = - let (Declaration_constant (an , _)) = Location.unwrap x in + let (Declaration_constant (an , _, _)) = Location.unwrap x in if (an.name = Var.of_name name) then Some an.annotated_expression else None @@ -539,4 +539,4 @@ let get_entry (lst : program) (name : string) : annotated_expression result = let program_environment (program : program) : full_environment = let last_declaration = Location.unwrap List.(hd @@ rev program) in match last_declaration with - | Declaration_constant (_ , (_ , post_env)) -> post_env + | Declaration_constant (_ , _, (_ , post_env)) -> post_env diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml index 14fbccbb5..d0c087892 100644 --- a/src/stages/ast_typed/misc_smart.ml +++ b/src/stages/ast_typed/misc_smart.ml @@ -8,7 +8,7 @@ let program_to_main : program -> string -> lambda result = fun p s -> let%bind (main , input_type , _) = let pred = fun d -> match d with - | Declaration_constant (d , _) when d.name = Var.of_name s -> Some d.annotated_expression + | Declaration_constant (d , _, _) when d.name = Var.of_name s -> Some d.annotated_expression | Declaration_constant _ -> None in let%bind main = @@ -23,7 +23,7 @@ let program_to_main : program -> string -> lambda result = fun p s -> let env = let aux = fun _ d -> match d with - | Declaration_constant (_ , (_ , post_env)) -> post_env in + | Declaration_constant (_ , _, (_ , post_env)) -> post_env in List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in let binder = Var.of_name "@contract_input" in let body = diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index 388a09eb7..50d2060ed 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -5,8 +5,10 @@ include Stage_common.Types type program = declaration Location.wrap list +and inline = bool + and declaration = - | Declaration_constant of (named_expression * (full_environment * full_environment)) + | Declaration_constant of (named_expression * inline * (full_environment * full_environment)) (* | Macro_declaration of macro_declaration *) and environment_element_definition = @@ -64,6 +66,7 @@ and let_in = { binder: expression_variable; rhs: ae; result: ae; + inline: inline; } and 'a expression' = diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index 66179745e..c012eed48 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -91,8 +91,8 @@ and expression' ppf (e:expression') = match e with | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Stage_common.PP.name name_l expression l Stage_common.PP.name name_r expression r | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b - | E_let_in ((name , _) , expr , body) -> - fprintf ppf "let %a = %a in ( %a )" Stage_common.PP.name name expression expr expression body + | E_let_in ((name , _) , inline, expr , body) -> + fprintf ppf "let %a = %a%a in ( %a )" Stage_common.PP.name name expression expr option_inline inline expression body | E_iterator (b , ((name , _) , body) , expr) -> fprintf ppf "for_%a %a of %a do ( %a )" Stage_common.PP.constant b Stage_common.PP.name name expression expr expression body | E_fold (((name , _) , body) , collection , initial) -> @@ -117,9 +117,17 @@ and function_ ppf ({binder ; body}:anon_function) = Stage_common.PP.name binder expression body -and assignment ppf ((n, e):assignment) = fprintf ppf "%a = %a;" Stage_common.PP.name n expression e +and assignment ppf ((n, i, e):assignment) = + fprintf ppf "%a = %a%a;" Stage_common.PP.name n expression e option_inline i -and declaration ppf ((n, e):assignment) = fprintf ppf "let %a = %a;" Stage_common.PP.name n expression e +and option_inline ppf inline = + if inline then + fprintf ppf "[@inline]" + else + fprintf ppf "" + +and declaration ppf ((n, i, e):assignment) = + fprintf ppf "let %a = %a%a;" Stage_common.PP.name n expression e option_inline i let tl_statement ppf (ass, _) = assignment ppf ass diff --git a/src/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml index f519f4a88..a7d34a6cb 100644 --- a/src/stages/mini_c/combinators.ml +++ b/src/stages/mini_c/combinators.ml @@ -172,8 +172,8 @@ let e_int expr : expression = Expression.make_tpl (expr, t_int) let e_unit : expression = Expression.make_tpl (E_literal D_unit, t_unit) let e_skip : expression = Expression.make_tpl (E_skip, t_unit) let e_var_int name : expression = e_int (E_variable name) -let e_let_in v tv expr body : expression = Expression.(make_tpl ( - E_let_in ((v , tv) , expr , body) , +let e_let_in v tv inline expr body : expression = Expression.(make_tpl ( + E_let_in ((v , tv) , inline, expr , body) , get_type body )) diff --git a/src/stages/mini_c/combinators.mli b/src/stages/mini_c/combinators.mli index 3f7d9876a..3f9b1552e 100644 --- a/src/stages/mini_c/combinators.mli +++ b/src/stages/mini_c/combinators.mli @@ -67,7 +67,7 @@ val e_int : Expression.t' -> Expression.t val e_unit : Expression.t val e_skip : Expression.t val e_var_int : expression_variable -> Expression.t -val e_let_in : expression_variable -> type_value -> Expression.t -> Expression.t -> Expression.t +val e_let_in : expression_variable -> type_value -> inline -> Expression.t -> Expression.t -> Expression.t val ez_e_sequence : Expression.t' -> Expression.t -> expression (* diff --git a/src/stages/mini_c/misc.ml b/src/stages/mini_c/misc.ml index df0387b19..a30bca8db 100644 --- a/src/stages/mini_c/misc.ml +++ b/src/stages/mini_c/misc.ml @@ -74,7 +74,7 @@ module Free_variables = struct expression (union (singleton l) b) bl ; expression (union (singleton r) b) br ; ] - | E_let_in ((v , _) , expr , body) -> + | E_let_in ((v , _) , _, expr , body) -> unions [ self expr ; expression (union (singleton v) b) body ; ] @@ -125,7 +125,7 @@ let get_entry (lst : program) (name : string) : (expression * int) result = let%bind entry_expression = trace_option (Errors.missing_entry_point name) @@ let aux x = - let (((decl_name , decl_expr) , _)) = x in + let (((decl_name , _, decl_expr) , _)) = x in if (Var.equal decl_name (Var.of_name name)) then Some decl_expr else None @@ -134,7 +134,7 @@ let get_entry (lst : program) (name : string) : (expression * int) result = in let entry_index = let aux x = - let (((decl_name , _) , _)) = x in + let (((decl_name , _, _) , _)) = x in Var.equal decl_name (Var.of_name name) in (List.length lst) - (List.find_index aux (List.rev lst)) - 1 @@ -148,8 +148,8 @@ type form_t = let aggregate_entry (lst : program) (form : form_t) : expression result = let wrapper = let aux prec cur = - let (((name , expr) , _)) = cur in - e_let_in name expr.type_value expr prec + let (((name , inline, expr) , _)) = cur in + e_let_in name expr.type_value inline expr prec in fun expr -> List.fold_right' aux expr lst in diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index 42e411add..ed0b24747 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -27,6 +27,8 @@ type environment_wrap = { type var_name = expression_variable type fun_name = expression_variable +type inline = bool + type value = | D_unit | D_bool of bool @@ -68,7 +70,7 @@ and expression' = | E_if_none of expression * expression * ((var_name * type_value) * expression) | E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression)) | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) - | E_let_in of ((var_name * type_value) * expression * expression) + | E_let_in of ((var_name * type_value) * inline * expression * expression) | E_sequence of (expression * expression) | E_assignment of (expression_variable * [`Left | `Right] list * expression) | E_update of (expression * ([`Left | `Right] list * expression) list) @@ -79,7 +81,7 @@ and expression = { type_value : type_value ; } -and assignment = var_name * expression +and assignment = var_name * inline * expression and toplevel_statement = assignment * environment_wrap diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 76d2ec7c1..fdcaae910 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -147,11 +147,11 @@ module Substitution = struct let%bind binder = s_variable ~v ~expr binder in let%bind body = s_annotated_expression ~v ~expr body in ok @@ T.E_lambda { binder; body } - | T.E_let_in { binder; rhs; result } -> + | T.E_let_in { binder; rhs; result; inline } -> let%bind binder = s_variable ~v ~expr binder in let%bind rhs = s_annotated_expression ~v ~expr rhs in let%bind result = s_annotated_expression ~v ~expr result in - ok @@ T.E_let_in { binder; rhs; result } + ok @@ T.E_let_in { binder; rhs; result; inline } | T.E_tuple vals -> let%bind vals = bind_map_list (s_annotated_expression ~v ~expr) vals in ok @@ T.E_tuple vals @@ -235,11 +235,11 @@ module Substitution = struct and s_declaration ~v ~expr : T.declaration w = function - Ast_typed.Declaration_constant (e, (env1, env2)) -> + Ast_typed.Declaration_constant (e, i, (env1, env2)) -> let%bind e = s_named_expression ~v ~expr e in let%bind env1 = s_full_environment ~v ~expr env1 in let%bind env2 = s_full_environment ~v ~expr env2 in - ok @@ Ast_typed.Declaration_constant (e, (env1, env2)) + ok @@ Ast_typed.Declaration_constant (e, i, (env1, env2)) and s_declaration_wrap ~v ~expr : T.declaration Location.wrap w = fun d -> Trace.bind_map_location (s_declaration ~v ~expr) d diff --git a/src/test/contracts/attributes.ligo b/src/test/contracts/attributes.ligo new file mode 100644 index 000000000..95aea1880 --- /dev/null +++ b/src/test/contracts/attributes.ligo @@ -0,0 +1,17 @@ +const x: int = 1; attributes ["inline"]; + +function foo (const a : int) : int is + block { + const test: int = 2 + a; attributes ["inline"]; + } with test; +attributes ["inline"]; + +const y: int = 1; attributes ["inline"; "other"]; + +function bar (const b : int) : int is + block { + function test (const z : int) : int is begin + const r : int = 2 + b + z + end with r; + attributes ["inline"; "foo"; "bar"]; + } with test(b); diff --git a/src/test/contracts/attributes.mligo b/src/test/contracts/attributes.mligo new file mode 100644 index 000000000..72038110f --- /dev/null +++ b/src/test/contracts/attributes.mligo @@ -0,0 +1,13 @@ +let x = 1 [@@inline] + +let foo (a: int): int = ( + let test = 2 + a [@@inline] in + test +) [@@inline] + +let y = 1 [@@inline][@@other] + +let bar (b: int): int = ( + let test = fun (z: int) -> 2 + b + z [@@inline][@@foo][@@bar] in + test b +) \ No newline at end of file diff --git a/src/test/contracts/attributes.religo b/src/test/contracts/attributes.religo new file mode 100644 index 000000000..c08916813 --- /dev/null +++ b/src/test/contracts/attributes.religo @@ -0,0 +1,18 @@ +[@inline] +let x = 1; + +[@inline] +let foo = (a: int): int => { + [@inline] + let test = 2 + a; + test; +}; + +[@inline][@other] +let y = 1; + +let bar = (b: int): int => { + [@inline][@foo][@bar] + let test = (z: int) => 2 + b + z; + test(b); +}; \ No newline at end of file diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index a3c3fe3cd..394bcc4f0 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1846,6 +1846,33 @@ let deep_access_ligo () : unit result = let make_expected = e_string "one" in expect_eq program "nested_record" make_input make_expected in ok () + +let attributes_ligo () : unit result = + let%bind program = type_file "./contracts/attributes.ligo" in + let%bind () = + let input = e_int 3 in + let expected = e_int 5 in + expect_eq program "foo" input expected + in + ok () + +let attributes_mligo () : unit result = + let%bind program = mtype_file "./contracts/attributes.mligo" in + let%bind () = + let input = e_int 3 in + let expected = e_int 5 in + expect_eq program "foo" input expected + in + ok () + +let attributes_religo () : unit result = + let%bind program = retype_file "./contracts/attributes.religo" in + let%bind () = + let input = e_int 3 in + let expected = e_int 5 in + expect_eq program "foo" input expected + in + ok () let entrypoints_ligo () : unit result = @@ -2127,6 +2154,9 @@ let main = test_suite "Integration (End to End)" [ test "entrypoints (ligo)" entrypoints_ligo ; test "curry (mligo)" curry ; test "type tuple destruct (mligo)" type_tuple_destruct ; + test "attributes (ligo)" attributes_ligo; + test "attributes (mligo)" attributes_mligo; + test "attributes (religo)" attributes_religo; test "let in multi-bind (mligo)" let_in_multi_bind ; test "tuple param destruct (mligo)" tuple_param_destruct ; test "empty case" empty_case ; diff --git a/src/test/md_file_tests.ml b/src/test/md_file_tests.ml index 6d8d491de..0401648d0 100644 --- a/src/test/md_file_tests.ml +++ b/src/test/md_file_tests.ml @@ -72,7 +72,7 @@ let compile_groups _filename grp_list = let%bind typed,_ = Compile.Of_simplified.compile simplified in let%bind mini_c = Compile.Of_typed.compile typed in bind_map_list - (fun ((_,exp),_) -> Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp) + (fun ((_, _, exp),_) -> Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp) mini_c ) grp_list in diff --git a/src/test/multisig_v2_tests.ml b/src/test/multisig_v2_tests.ml index e42fd62fe..eb4198c3e 100644 --- a/src/test/multisig_v2_tests.ml +++ b/src/test/multisig_v2_tests.ml @@ -35,7 +35,7 @@ let empty_message = e_lambda (Var.of_name "arguments") empty_op_list let empty_message2 = e_lambda (Var.of_name "arguments") (Some t_bytes) (Some (t_list t_operation)) - ( e_let_in ((Var.of_name "foo"),Some t_unit) (e_unit ()) empty_op_list) + ( e_let_in ((Var.of_name "foo"),Some t_unit) false (e_unit ()) empty_op_list) let send_param msg = e_constructor "Send" msg let withdraw_param = e_constructor "Withdraw" empty_message diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 928e828e8..21f3fb1fc 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -93,7 +93,7 @@ let run_typed_program_with_simplified_input ?options (program: Ast_typed.program) (entry_point: string) (input: Ast_simplified.expression) : Ast_simplified.expression result = let%bind michelson_program = typed_program_with_simplified_input_to_michelson program entry_point input in - let%bind michelson_output = Ligo.Run.Of_michelson.run ?options michelson_program.expr michelson_program.expr_ty in + let%bind michelson_output = Ligo.Run.Of_michelson.run_no_failwith ?options michelson_program.expr michelson_program.expr_ty in Uncompile.uncompile_typed_program_entry_function_result program entry_point michelson_output let expect ?options program entry_point input expecter = @@ -147,7 +147,7 @@ let expect_evaluate program entry_point expecter = let%bind mini_c = Ligo.Compile.Of_typed.compile program in let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in let%bind michelson_value = Ligo.Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in - let%bind res_michelson = Ligo.Run.Of_michelson.run michelson_value.expr michelson_value.expr_ty in + let%bind res_michelson = Ligo.Run.Of_michelson.run_no_failwith michelson_value.expr michelson_value.expr_ty in let%bind res_simpl = Uncompile.uncompile_typed_program_entry_expression_result program entry_point res_michelson in expecter res_simpl