diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 20624230c..ad7bb28f5 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -24,9 +24,13 @@ let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (inp Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ Memory_proto_alpha.parse_michelson_data input_michelson input_ty in + let body = Michelson.strip_annots body in + let open! Memory_proto_alpha.Protocol.Script_ir_translator in + let top_level = Toplevel { storage_type = output_ty ; param_type = input_ty ; + root_name = None ; legacy_create_contract_literal = false } in let%bind descr = Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ - Memory_proto_alpha.parse_michelson body + Memory_proto_alpha.parse_michelson ~top_level body (Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in let open! Memory_proto_alpha.Protocol.Script_interpreter in let%bind (Item(output, Empty)) = diff --git a/src/passes/4-typer-new/typer.ml b/src/passes/4-typer-new/typer.ml index c281ec12d..4581d916c 100644 --- a/src/passes/4-typer-new/typer.ml +++ b/src/passes/4-typer-new/typer.ml @@ -438,6 +438,9 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e | E_literal (Literal_key s) -> ( return_wrapped (e_key s) state @@ Wrap.literal (t_key ()) ) + | E_literal (Literal_chain_id s) -> ( + return_wrapped (e_chain_id s) state @@ Wrap.literal (t_chain_id ()) + ) | E_literal (Literal_bytes b) -> ( return_wrapped (e_bytes b) state @@ Wrap.literal (t_bytes ()) ) @@ -1007,6 +1010,7 @@ let untype_literal (l:O.literal) : I.literal result = | Literal_int n -> ok (Literal_int n) | Literal_string s -> ok (Literal_string s) | Literal_key s -> ok (Literal_key s) + | Literal_chain_id s -> ok (Literal_chain_id s) | Literal_signature s -> ok (Literal_signature s) | Literal_bytes b -> ok (Literal_bytes b) | Literal_address s -> ok (Literal_address s) diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index f5e4e89dd..89f92ec76 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -406,6 +406,8 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O. return (E_literal (Literal_string s)) (t_string ()) | E_literal (Literal_key s) -> return (E_literal (Literal_key s)) (t_key ()) + | E_literal (Literal_chain_id s) -> + return (E_literal (Literal_chain_id s)) (t_chain_id ()) | E_literal (Literal_signature s) -> return (E_literal (Literal_signature s)) (t_signature ()) | E_literal (Literal_bytes s) -> @@ -814,6 +816,7 @@ let untype_literal (l:O.literal) : I.literal result = | Literal_string s -> ok (Literal_string s) | Literal_signature s -> ok (Literal_signature s) | Literal_key s -> ok (Literal_key s) + | Literal_chain_id s -> ok (Literal_chain_id s) | Literal_bytes b -> ok (Literal_bytes b) | Literal_address s -> ok (Literal_address s) | Literal_operation s -> ok (Literal_operation s) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index aacd50e0d..6bf94ca27 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -131,6 +131,7 @@ let rec transpile_type (t:AST.type_value) : type_value result = | T_constant (Type_name "operation", []) -> ok (T_base Base_operation) | T_constant (Type_name "signature", []) -> ok (T_base Base_signature) | T_constant (Type_name "key", []) -> ok (T_base Base_key) + | T_constant (Type_name "chain_id", []) -> ok (T_base Base_chain_id) | T_constant (Type_name "contract", [x]) -> let%bind x' = transpile_type x in ok (T_contract x') @@ -240,6 +241,7 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with | Literal_address s -> D_string s | Literal_signature s -> D_string s | Literal_key s -> D_string s + | Literal_chain_id s -> D_string s | Literal_operation op -> D_operation op | Literal_unit -> D_unit diff --git a/src/passes/6-transpiler/untranspiler.ml b/src/passes/6-transpiler/untranspiler.ml index 70d2933c5..e8fd27683 100644 --- a/src/passes/6-transpiler/untranspiler.ml +++ b/src/passes/6-transpiler/untranspiler.ml @@ -156,6 +156,12 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression get_string v in return (E_literal (Literal_key n)) ) + | T_constant (Type_name "chain_id", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "chain_id" v) @@ + get_string v in + return (E_literal (Literal_chain_id n)) + ) | T_constant (Type_name "set", [ty]) -> ( let%bind lst = trace_strong (wrong_mini_c_value "set" v) @@ diff --git a/src/passes/8-compiler/compiler_type.ml b/src/passes/8-compiler/compiler_type.ml index 03754c03e..bef509a45 100644 --- a/src/passes/8-compiler/compiler_type.ml +++ b/src/passes/8-compiler/compiler_type.ml @@ -32,6 +32,7 @@ module Ty = struct let mutez = Mutez_t None let string = String_t None let key = Key_t None + let chain_id = Chain_id_t None let list a = List_t (a, None , has_big_map a) let set a = Set_t (a, None) let address = Address_t None @@ -70,6 +71,7 @@ module Ty = struct | Base_operation -> fail (not_comparable "operation") | Base_signature -> fail (not_comparable "signature") | Base_key -> fail (not_comparable "key") + | Base_chain_id -> fail (not_comparable "chain_id") let comparable_type : type_value -> ex_comparable_ty result = fun tv -> match tv with @@ -100,6 +102,7 @@ module Ty = struct | Base_operation -> return operation | Base_signature -> return signature | Base_key -> return key + | Base_chain_id -> return chain_id let rec type_ : type_value -> ex_ty result = function @@ -183,6 +186,7 @@ let base_type : type_base -> O.michelson result = | Base_operation -> ok @@ O.prim T_operation | Base_signature -> ok @@ O.prim T_signature | Base_key -> ok @@ O.prim T_key + | Base_chain_id -> ok @@ O.prim T_chain_id let rec type_ : type_value -> O.michelson result = function diff --git a/src/passes/8-compiler/uncompiler.ml b/src/passes/8-compiler/uncompiler.ml index 62adefd48..5440ac92a 100644 --- a/src/passes/8-compiler/uncompiler.ml +++ b/src/passes/8-compiler/uncompiler.ml @@ -31,6 +31,11 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = trace_option (simple_error "too big to fit an int") @@ Alpha_context.Script_int.to_int n in ok @@ D_nat n + | (Chain_id_t _), id -> + let str = Tezos_crypto.Base58.simple_encode + (Tezos_base__TzPervasives.Chain_id.b58check_encoding) + id in + ok @@ D_string str | (Key_t _ ), n -> let%bind s = match n with | Ed25519 x -> ok @@ TP.Base58.simple_encode (TP.Ed25519.Public_key.b58check_encoding) x diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index b19d1724a..2d4b20646 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -52,12 +52,14 @@ module Simplify = struct ("set" , "set") ; ("map" , "map") ; ("big_map" , "big_map") ; + ("chain_id" , "chain_id") ; ] module Pascaligo = struct let constants = [ ("get_force" , "MAP_GET_FORCE") ; + ("get_chain_id", "CHAIN_ID"); ("transaction" , "CALL") ; ("get_contract" , "CONTRACT") ; ("get_entrypoint" , "CONTRACT_ENTRYPOINT") ; @@ -90,7 +92,6 @@ module Simplify = struct ("list_iter" , "LIST_ITER") ; ("list_fold" , "LIST_FOLD") ; ("list_map" , "LIST_MAP") ; - (*ici*) ("map_iter" , "MAP_ITER") ; ("map_map" , "MAP_MAP") ; ("map_fold" , "MAP_FOLD") ; @@ -459,7 +460,11 @@ module Typer = struct let balance = constant "BALANCE" @@ t_mutez () - let address = constant "ADDRESS" @@ t_address () + let chain_id = constant "CHAIN_ID" @@ t_chain_id () + + let address = typer_1 "ADDRESS" @@ fun contract -> + let%bind () = assert_t_contract contract in + ok @@ t_address () let now = constant "NOW" @@ t_timestamp () @@ -775,6 +780,7 @@ module Typer = struct check_signature ; sender ; source ; + chain_id ; unit ; balance ; amount ; @@ -858,7 +864,7 @@ module Compiler = struct ("UNIT" , simple_constant @@ prim I_UNIT) ; ("BALANCE" , simple_constant @@ prim I_BALANCE) ; ("AMOUNT" , simple_constant @@ prim I_AMOUNT) ; - ("ADDRESS" , simple_constant @@ prim I_ADDRESS) ; + ("ADDRESS" , simple_unary @@ prim I_ADDRESS) ; ("NOW" , simple_constant @@ prim I_NOW) ; ("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ; ("SOURCE" , simple_constant @@ prim I_SOURCE) ; @@ -875,6 +881,7 @@ module Compiler = struct ("PACK" , simple_unary @@ prim I_PACK) ; ("CONCAT" , simple_binary @@ prim I_CONCAT) ; ("CONS" , simple_binary @@ prim I_CONS) ; + ("CHAIN_ID", simple_constant @@ prim I_CHAIN_ID ) ; ] (* diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml index 3a8101c12..a17b93c61 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/ast_simplified/PP.ml @@ -31,6 +31,7 @@ let literal ppf (l:literal) = match l with | Literal_address s -> fprintf ppf "@%S" s | Literal_signature s -> fprintf ppf "@%S" s | Literal_key s -> fprintf ppf "@%S" s + | Literal_chain_id s -> fprintf ppf "@%S" s | Literal_operation _ -> fprintf ppf "Operation(...bytes)" let rec expression ppf (e:expression) = match e.expression with diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml index 21b2e570c..86ce9aee5 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/ast_simplified/combinators.ml @@ -66,6 +66,7 @@ let e_address ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_add let e_mutez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_mutez s) let e_signature ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_signature s) let e_key ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key s) +let e_chain_id ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_chain_id s) let e'_bytes b : expression' result = let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in ok @@ E_literal (Literal_bytes bytes) diff --git a/src/stages/ast_simplified/combinators.mli b/src/stages/ast_simplified/combinators.mli index beff41532..9e8761e1d 100644 --- a/src/stages/ast_simplified/combinators.mli +++ b/src/stages/ast_simplified/combinators.mli @@ -55,6 +55,7 @@ val e_string : ?loc:Location.t -> string -> expression val e_address : ?loc:Location.t -> string -> expression val e_signature : ?loc:Location.t -> string -> expression val e_key : ?loc:Location.t -> string -> expression +val e_chain_id : ?loc:Location.t -> string -> expression val e_mutez : ?loc:Location.t -> int -> expression val e'_bytes : string -> expression' result val e_bytes : ?loc:Location.t -> string -> expression result diff --git a/src/stages/ast_simplified/misc.ml b/src/stages/ast_simplified/misc.ml index 3e088906f..5969d4732 100644 --- a/src/stages/ast_simplified/misc.ml +++ b/src/stages/ast_simplified/misc.ml @@ -67,6 +67,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_key a, Literal_key b when a = b -> ok () | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b + | Literal_chain_id a, Literal_chain_id b when a = b -> ok () + | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b + | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b let rec assert_value_eq (a, b: (expression * expression )) : unit result = let error_content () = diff --git a/src/stages/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml index 306998361..185d23b23 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/ast_simplified/types.ml @@ -97,6 +97,7 @@ and literal = | Literal_timestamp of int | Literal_signature of string | Literal_key of string + | Literal_chain_id of string | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation and 'a matching = diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 1e0adc57f..5fdf5e849 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -77,6 +77,7 @@ and literal ppf (l:literal) : unit = | Literal_signature s -> fprintf ppf "@%s" s | Literal_key s -> fprintf ppf "@%s" s | Literal_operation _ -> fprintf ppf "Operation(...bytes)" + | Literal_chain_id s -> fprintf ppf "@%s" s and single_record_patch ppf ((s, ae) : string * ae) = fprintf ppf "%s <- %a" s annotated_expression ae diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 252532542..d32edf170 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -19,6 +19,7 @@ let t_key_hash ?s () : type_value = make_t (T_constant (Type_name "key_hash", [] let t_signature ?s () : type_value = make_t (T_constant (Type_name "signature", [])) s let t_int ?s () : type_value = make_t (T_constant (Type_name "int", [])) s let t_address ?s () : type_value = make_t (T_constant (Type_name "address", [])) s +let t_chain_id ?s () : type_value = make_t (T_constant (Type_name "chain_id", [])) s let t_operation ?s () : type_value = make_t (T_constant (Type_name "operation", [])) s let t_nat ?s () : type_value = make_t (T_constant (Type_name "nat", [])) s let t_mutez ?s () : type_value = make_t (T_constant (Type_name "tez", [])) s @@ -185,6 +186,10 @@ let assert_t_key = get_t_key let assert_t_signature = get_t_signature let assert_t_key_hash = get_t_key_hash +let assert_t_contract (t:type_value) : unit result = match t.type_value' with + | T_constant (Type_name "contract", _) -> ok () + | _ -> simple_fail "not a contract" + let assert_t_list t = let%bind _ = get_t_list t in ok () @@ -241,6 +246,7 @@ let e_timestamp s : expression = E_literal (Literal_timestamp s) let e_address s : expression = E_literal (Literal_address s) let e_signature s : expression = E_literal (Literal_signature s) let e_key s : expression = E_literal (Literal_key s) +let e_chain_id s : expression = E_literal (Literal_chain_id s) let e_operation s : expression = E_literal (Literal_operation s) let e_lambda l : expression = E_lambda l let e_pair a b : expression = E_tuple [a; b] diff --git a/src/stages/ast_typed/combinators.mli b/src/stages/ast_typed/combinators.mli index 14cfcb52e..12b84f779 100644 --- a/src/stages/ast_typed/combinators.mli +++ b/src/stages/ast_typed/combinators.mli @@ -19,6 +19,7 @@ val t_int : ?s:S.type_expression -> unit -> type_value val t_nat : ?s:S.type_expression -> unit -> type_value val t_mutez : ?s:S.type_expression -> unit -> type_value val t_address : ?s:S.type_expression -> unit -> type_value +val t_chain_id : ?s:S.type_expression -> unit -> type_value val t_signature : ?s:S.type_expression -> unit -> type_value val t_unit : ?s:S.type_expression -> unit -> type_value val t_option : type_value -> ?s:S.type_expression -> unit -> type_value @@ -102,6 +103,7 @@ val assert_t_int : type_value -> unit result val assert_t_nat : type_value -> unit result val assert_t_bool : type_value -> unit result val assert_t_unit : type_value -> unit result +val assert_t_contract : type_value -> unit result (* val e_record : ae_map -> expression val ez_e_record : ( string * annotated_expression ) list -> expression @@ -121,6 +123,7 @@ val e_timestamp : int -> expression val e_address : string -> expression val e_signature : string -> expression val e_key : string -> expression +val e_chain_id : string -> expression val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression val e_lambda : lambda -> expression val e_pair : value -> value -> expression diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 4626ad6a3..f315d9af2 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -386,6 +386,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_key a, Literal_key b when a = b -> ok () | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b + | Literal_chain_id a, Literal_chain_id b when a = b -> ok () + | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b + | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index c4f23521e..4615f156a 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -128,6 +128,7 @@ and literal = | Literal_address of string | Literal_signature of string | Literal_key of string + | Literal_chain_id of string | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation and access = diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index df06324f8..62b7bec2a 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -22,6 +22,7 @@ let type_base ppf : type_base -> _ = function | Base_operation -> fprintf ppf "operation" | Base_signature -> fprintf ppf "signature" | Base_key -> fprintf ppf "key" + | Base_chain_id -> fprintf ppf "chain_id" let rec type_ ppf : type_value -> _ = function | T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index d171d8f19..c109fc525 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -7,6 +7,7 @@ type type_base = | Base_timestamp | Base_string | Base_bytes | Base_address | Base_key | Base_operation | Base_signature + | Base_chain_id type 'a annotated = string option * 'a diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 916e6d60a..96f6c472f 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -103,6 +103,7 @@ module Substitution = struct | (T.Literal_address _ as x) | (T.Literal_signature _ as x) | (T.Literal_key _ as x) + | (T.Literal_chain_id _ as x) | (T.Literal_operation _ as x) -> ok @@ x and s_matching_expr ~v ~expr : T.matching_expr w = fun _ -> diff --git a/src/test/contracts/chain_id.ligo b/src/test/contracts/chain_id.ligo new file mode 100644 index 000000000..e7283adf2 --- /dev/null +++ b/src/test/contracts/chain_id.ligo @@ -0,0 +1,5 @@ + +function get_chain_id (const tt : chain_id) : chain_id is + block { + var toto : chain_id := get_chain_id ; + } with ( toto ) \ No newline at end of file diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 5eb3281ea..a6f79b7ee 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1267,7 +1267,18 @@ let entrypoints_ligo () : unit result = (* hmm... *) ok () +let chain_id () : unit result = + let%bind program = type_file "./contracts/chain_id.ligo" in + let pouet = Tezos_crypto.Base58.simple_encode + Tezos_base__TzPervasives.Chain_id.b58check_encoding + Tezos_base__TzPervasives.Chain_id.zero in + let make_input = e_chain_id pouet in + let make_expected = e_chain_id pouet in + let%bind () = expect_eq program "get_chain_id" make_input make_expected in + ok () + let main = test_suite "Integration (End to End)" [ + test "chain id" chain_id ; test "type alias" type_alias ; test "function" function_ ; test "blockless function" blockless;