Bla

src/ast_typed/combinators.ml

@@ -138,16 +138,15 @@ let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value'
   | _ -> simple_fail "not a record type"
 
 let get_t_map (t:type_value) : (type_value * type_value) result =
-  match t.type_value' with
-  | T_constant ("map", [k;v]) -> ok (k, v)
-  | T_constant ("big_map", [k;v]) -> ok (k, v)
-  | _ -> simple_fail "get: not a map or a big_map"
-
-let get_t_map_not_big_map (t:type_value) : (type_value * type_value) result =
   match t.type_value' with
   | T_constant ("map", [k;v]) -> ok (k, v)
   | _ -> simple_fail "get: not a map"
 
+let get_t_big_map (t:type_value) : (type_value * type_value) result =
+  match t.type_value' with
+  | T_constant ("big_map", [k;v]) -> ok (k, v)
+  | _ -> simple_fail "get: not a big_map"
+
 let get_t_map_key : type_value -> type_value result = fun t ->
   let%bind (key , _) = get_t_map t in
   ok key
@@ -156,11 +155,20 @@ let get_t_map_value : type_value -> type_value result = fun t ->
   let%bind (_ , value) = get_t_map t in
   ok value
 
+let get_t_big_map_key : type_value -> type_value result = fun t ->
+  let%bind (key , _) = get_t_big_map t in
+  ok key
+
+let get_t_big_map_value : type_value -> type_value result = fun t ->
+  let%bind (_ , value) = get_t_big_map t in
+  ok value
+
 let assert_t_map = fun t ->
   let%bind _ = get_t_map t in
   ok ()
 
-let is_t_map_not_big_map = Function.compose to_bool get_t_map_not_big_map
+let is_t_map = Function.compose to_bool get_t_map
+let is_t_big_map = Function.compose to_bool get_t_big_map
 
 let assert_t_tez : type_value -> unit result = get_t_tez
 let assert_t_key = get_t_key

src/compiler/compiler_program.ml

@@ -35,7 +35,7 @@ let get_predicate : string -> type_value -> expression list -> predicate result
       | "MAP_REMOVE" ->
           let%bind v = match lst with
             | [ _ ; expr ] ->
-                let%bind (_, v) = Mini_c.Combinators.(get_t_map (Expression.get_type expr)) in
+                let%bind (_, v) = Mini_c.Combinators.(bind_map_or (get_t_map , get_t_big_map) (Expression.get_type expr)) in
                 ok v
             | _ -> simple_fail "mini_c . MAP_REMOVE" in
           let%bind v_ty = Compiler_type.type_ v in
@@ -107,6 +107,15 @@ let rec translate_value (v:value) ty : michelson result = match v with
       let aux (a, b) = prim ~children:[a;b] D_Elt in
       ok @@ seq @@ List.map aux sorted
     )
+  | D_big_map lst -> (
+      let%bind (k_ty , v_ty) = get_t_big_map ty in
+      let%bind lst' =
+        let aux (k , v) = bind_pair (translate_value k k_ty , translate_value v v_ty) in
+        bind_map_list aux lst in
+      let sorted = List.sort (fun (x , _) (y , _) -> compare x y) lst' in
+      let aux (a, b) = prim ~children:[a;b] D_Elt in
+      ok @@ seq @@ List.map aux sorted
+    )
   | D_list lst -> (
       let%bind e_ty = get_t_list ty in
       let%bind lst' = bind_map_list (fun x -> translate_value x e_ty) lst in

src/mini_c/PP.ml

@@ -62,6 +62,7 @@ let rec value ppf : value -> unit = function
   | D_none -> fprintf ppf "None"
   | D_some s -> fprintf ppf "Some (%a)" value s
   | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m
+  | D_big_map m -> fprintf ppf "Big_map[%a]" (list_sep_d value_assoc) m
   | D_list lst -> fprintf ppf "List[%a]" (list_sep_d value) lst
   | D_set lst -> fprintf ppf "Set[%a]" (list_sep_d value) lst
 

src/mini_c/combinators.ml

@@ -62,6 +62,10 @@ let get_map (v:value) = match v with
   | D_map lst -> ok lst
   | _ -> simple_fail "not a map"
 
+let get_big_map (v:value) = match v with
+  | D_big_map lst -> ok lst
+  | _ -> simple_fail "not a big_map"
+
 let get_list (v:value) = match v with
   | D_list lst -> ok lst
   | _ -> simple_fail "not a list"
@@ -88,9 +92,12 @@ let get_t_or (t:type_value) = match t with
 
 let get_t_map (t:type_value) = match t with
   | T_map kv -> ok kv
-  | T_big_map kv -> ok kv
   | _ -> simple_fail "not a type map"
 
+let get_t_big_map (t:type_value) = match t with
+  | T_big_map kv -> ok kv
+  | _ -> simple_fail "not a type big_map"
+
 let get_t_list (t:type_value) = match t with
   | T_list t -> ok t
   | _ -> simple_fail "not a type list"

src/mini_c/types.ml

@@ -48,6 +48,7 @@ type value =
   | D_some of value
   | D_none
   | D_map of (value * value) list
+  | D_big_map of (value * value) list
   | D_list of value list
   | D_set of value list
   (* | `Macro of anon_macro ... The future. *)

src/operators/operators.ml

@@ -235,53 +235,53 @@ module Typer = struct
     ok tl
 
   let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m ->
-    let%bind (src , _) = get_t_map m in
+    let%bind (src , _) = bind_map_or (get_t_map , get_t_big_map) m in
     let%bind () = assert_type_value_eq (src , k) in
     ok m
 
   let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m ->
-    let%bind (src, dst) = get_t_map m in
+    let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
     let%bind () = assert_type_value_eq (src, k) in
     let%bind () = assert_type_value_eq (dst, v) in
     ok m
 
   let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m ->
-    let%bind (src, dst) = get_t_map m in
+    let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
     let%bind () = assert_type_value_eq (src, k) in
     let%bind v' = get_t_option v in
     let%bind () = assert_type_value_eq (dst, v') in
     ok m
 
   let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m ->
-    let%bind (src, _dst) = get_t_map m in
+    let%bind (src, _dst) = bind_map_or (get_t_map , get_t_big_map) m in
     let%bind () = assert_type_value_eq (src, k) in
     ok @@ t_bool ()
 
   let map_find : typer = typer_2 "MAP_FIND" @@ fun k m ->
-    let%bind (src, dst) = get_t_map m in
+    let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
     let%bind () = assert_type_value_eq (src, k) in
     ok @@ dst
 
   let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m ->
-    let%bind (src, dst) = get_t_map m in
+    let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
     let%bind () = assert_type_value_eq (src, k) in
     ok @@ t_option dst ()
 
   let map_iter : typer = typer_2 "MAP_ITER" @@ fun m f ->
-    let%bind (k, v) = get_t_map_not_big_map m in
+    let%bind (k, v) = get_t_map m in
     let%bind (arg , res) = get_t_function f in
     let%bind () = assert_eq_1 arg (t_pair k v ()) in
     let%bind () = assert_eq_1 res (t_unit ()) in
     ok @@ t_unit ()
 
   let map_map : typer = typer_2 "MAP_MAP" @@ fun m f ->
-    let%bind (k, v) = get_t_map_not_big_map m in
+    let%bind (k, v) = get_t_map m in
     let%bind (arg , res) = get_t_function f in
     let%bind () = assert_eq_1 arg (t_pair k v ()) in
     ok @@ t_map k res ()
 
   let map_fold : typer = typer_2 "MAP_FOLD" @@ fun f m ->
-    let%bind (k, v) = get_t_map_not_big_map m in
+    let%bind (k, v) = get_t_map m in
     let%bind (arg_1 , res) = get_t_function f in
     let%bind (arg_2 , res') = get_t_function res in
     let%bind (arg_3 , res'') = get_t_function res' in
@@ -293,7 +293,7 @@ module Typer = struct
   let size = typer_1 "SIZE" @@ fun t ->
     let%bind () =
       Assert.assert_true @@
-      (is_t_map_not_big_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t) in
+      (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t ) in
     ok @@ t_nat ()
 
   let slice = typer_3 "SLICE" @@ fun i j s ->
@@ -312,7 +312,7 @@ module Typer = struct
     ok @@ t_unit ()
 
   let get_force = typer_2 "MAP_GET_FORCE" @@ fun i m ->
-    let%bind (src, dst) = get_t_map m in
+    let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
     let%bind _ = assert_type_value_eq (src, i) in
     ok dst
 
@@ -641,6 +641,8 @@ module Compiler = struct
     ("MAP_GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ;
     ("MAP_FIND" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) ;
     ("MAP_GET" , simple_binary @@ prim I_GET) ;
+    ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ;
+    ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ;
     ("SIZE" , simple_unary @@ prim I_SIZE) ;
     ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ;
     ("ASSERT_INFERRED" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ;
@@ -655,8 +657,6 @@ module Compiler = struct
     ("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ;
     ("SOURCE" , simple_constant @@ prim I_SOURCE) ;
     ("SENDER" , simple_constant @@ prim I_SENDER) ;
-    ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ;
-    ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ;
     ("SET_MEM" , simple_binary @@ prim I_MEM) ;
     ("SET_ADD" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE]) ;
     ("SET_REMOVE" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE]) ;

src/transpiler/transpiler.ml

@@ -434,7 +434,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind (init : expression) = return @@ E_make_empty_set t in
       bind_fold_list aux init lst'
     )
-  | (E_map m | E_big_map m) -> (
+  | E_map m -> (
       let%bind (src, dst) =
         trace_strong (corner_case ~loc:__LOC__ "not a map") @@
         Mini_c.Combinators.get_t_map tv in
@@ -448,6 +448,20 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
       let init = return @@ E_make_empty_map (src, dst) in
       List.fold_left aux init m
     )
+  | E_big_map m -> (
+      let%bind (src, dst) =
+        trace_strong (corner_case ~loc:__LOC__ "not a map") @@
+        Mini_c.Combinators.get_t_big_map tv in
+      let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
+        let%bind prev' = prev in
+        let%bind (k', v') =
+          let v' = e_a_some v ae.environment in
+          bind_map_pair (translate_annotated_expression) (k , v') in
+        return @@ E_constant ("UPDATE", [k' ; v' ; prev'])
+      in
+      let init = return @@ E_make_empty_map (src, dst) in
+      List.fold_left aux init m
+    )
   | E_look_up dsi -> (
       let%bind (ds', i') = bind_map_pair f dsi in
       return @@ E_constant ("MAP_GET", [i' ; ds'])
@@ -800,8 +814,8 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
     )
   | T_constant ("big_map", [k_ty;v_ty]) -> (
       let%bind lst =
-        trace_strong (wrong_mini_c_value "map" v) @@
+        trace_strong (wrong_mini_c_value "big_map" v) @@
-        get_map v in
+        get_big_map v in
       let%bind lst' =
         let aux = fun (k, v) ->
           let%bind k' = untranspile k k_ty in

src/typer/typer.ml

@@ -451,7 +451,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
           )
         | Access_map ae' -> (
             let%bind ae'' = type_expression e ae' in
-            let%bind (k , v) = get_t_map prev.type_annotation in
+            let%bind (k , v) = bind_map_or (get_t_map , get_t_big_map) prev.type_annotation in
             let%bind () =
               Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in
             return (E_look_up (prev , ae'')) v
@@ -570,7 +570,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
             bind_fold_list aux None
             @@ List.map get_type_annotation
             @@ List.map fst lst' in
-          let%bind annot = bind_map_option get_t_map_key tv_opt in
+          let%bind annot = bind_map_option get_t_big_map_key tv_opt in
           trace (simple_info "empty map expression without a type annotation") @@
           O.merge_annotation annot sub (needs_annotation ae "this map literal")
         in
@@ -579,7 +579,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
             bind_fold_list aux None
             @@ List.map get_type_annotation
             @@ List.map snd lst' in
-          let%bind annot = bind_map_option get_t_map_value tv_opt in
+          let%bind annot = bind_map_option get_t_big_map_value tv_opt in
           trace (simple_info "empty map expression without a type annotation") @@
           O.merge_annotation annot sub (needs_annotation ae "this map literal")
         in
@@ -644,7 +644,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
       return (E_application (f' , arg)) tv
   | E_look_up dsi ->
       let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in
-      let%bind (src, dst) = get_t_map ds.type_annotation in
+      let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in
       let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in
       return (E_look_up (ds , ind)) (t_option dst ())
   (* Advanced *)