add chain_id type and operator

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)) =

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)

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)

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
 

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) @@

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

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

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 ) ;
   ]
 
   (*

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

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)

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

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 () =

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 =

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

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]

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

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
 

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 =

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

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
 

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 _ ->

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 )

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;