better mini_c instructions

src/ligo/contracts/match.ligo

@@ -12,7 +12,7 @@ function match_option (const o : option(int)) : int is
   begin
   case o of
   | None -> skip
-  | Some(s) -> result := s
+  | Some(s) -> skip // result := s
   end
   end with result
 

src/ligo/mini_c/PP.ml

@@ -94,13 +94,14 @@ and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expressio
 and statement ppf ((s, _) : statement) = match s with
   | S_environment_extend -> fprintf ppf "extend"
   | S_environment_restrict -> fprintf ppf "restrict"
+  | S_environment_add (name, tv) -> fprintf ppf "add %s %a" name type_ tv
   | S_declaration ass -> declaration ppf ass
   | S_assignment ass -> assignment ppf ass
   | S_cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e
   | S_patch (r, path, e) ->
       let aux = fun ppf -> function `Left -> fprintf ppf ".L" | `Right -> fprintf ppf ".R" in
       fprintf ppf "%s%a := %a" r (list aux) path expression e
-  | S_if_none (expr, none, (name, some)) -> fprintf ppf "if_none (%a) %a %s.%a" expression expr block none name block some
+  | S_if_none (expr, none, ((name, _), some)) -> fprintf ppf "if_none (%a) %a %s->%a" expression expr block none name block some
   | S_while (e, b) -> fprintf ppf "while (%a) %a" expression e block b
 
 and block ppf ((b, _):block) =

src/ligo/mini_c/combinators.ml

@@ -111,6 +111,7 @@ let statement s' e : statement =
   match s' with
   | S_environment_extend -> s', environment_wrap e (Compiler_environment.extend e)
   | S_environment_restrict -> s', environment_wrap e (Compiler_environment.restrict e)
+  | S_environment_add (name, tv) -> s', environment_wrap e (Compiler_environment.add (name, tv) e)
   | S_cond _ -> s', id_environment_wrap e
   | S_if_none _ -> s', id_environment_wrap e
   | S_while _ -> s', id_environment_wrap e
@@ -126,6 +127,21 @@ let block (statements:statement list) : block result =
       let last = List.(nth lst (length lst - 1)) in
       ok (lst, environment_wrap (snd first).pre_environment (snd last).post_environment)
 
+let append_statement' : block -> statement' -> block = fun b s' ->
+  let b_wrap = snd b in
+  let s = statement s' b_wrap.post_environment in
+  let s_wrap = snd s in
+  let b_wrap' = { b_wrap with post_environment = s_wrap.post_environment } in
+  let b_content = fst b in
+  (b_content @ [s], b_wrap')
+
+let prepend_statement : statement -> block -> block = fun s b ->
+  let s_wrap = snd s in
+  let b_wrap = snd b in
+  let b_wrap' = { b_wrap with pre_environment = s_wrap.pre_environment } in
+  let b_content = fst b in
+  (s :: b_content, b_wrap')
+
 let statements (lst:(environment -> statement) list) e : statement list =
   let rec aux lst e = match lst with
     | [] -> []

src/ligo/mini_c/compiler.ml

@@ -295,6 +295,10 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
         ok @@ Environment.to_michelson_extend w_env.pre_environment
     | S_environment_restrict ->
         Environment.to_michelson_restrict w_env.pre_environment
+    | S_environment_add _ ->
+        simple_fail "not ready yet"
+    (* | S_environment_add (name, tv) ->
+     *     Environment.to_michelson_add (name, tv) w_env.pre_environment *)
     | S_declaration (s, ((_, tv, _) as expr)) ->
         let%bind expr = translate_expression expr in
         let%bind add = Environment.to_michelson_add (s, tv) w_env.pre_environment in
@@ -331,19 +335,17 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
             i_push_unit ;
             expr ;
             prim I_CAR ;
-            dip @@ Environment.to_michelson_extend w_env.pre_environment ;
             prim ~children:[seq [a'];seq [b']] I_IF ;
           ])
-    | S_if_none (expr, none, (_, some)) ->
+    | S_if_none (expr, none, ((name, tv), some)) ->
         let%bind expr = translate_expression expr in
         let%bind none' = translate_regular_block none in
         let%bind some' = translate_regular_block some in
         let%bind add =
-          let env = Environment.extend w_env.pre_environment in
+          let env' = Environment.extend w_env.pre_environment in
-          Environment.to_michelson_anonymous_add env in
+          Environment.to_michelson_add (name, tv) env' in
         ok @@ (seq [
             i_push_unit ; expr ; i_car ;
-            dip @@ Environment.to_michelson_extend w_env.pre_environment ;
             prim ~children:[
               seq [none'] ;
               seq [add ; some'] ;
@@ -383,7 +385,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
       let%bind pre_env_michelson = Environment.to_michelson_type w_env.pre_environment in
       let%bind post_env_michelson = Environment.to_michelson_type w_env.post_environment in
       ok @@ Format.asprintf
-        "statement : %a\ncode : %a\npre type : %a\npost type : %a"
+        "statement : %a\ncode : %a\npre type : %a\npost type : %a\n"
         PP.statement s
         Michelson.pp code
         Michelson.pp pre_env_michelson

src/ligo/mini_c/compiler_environment.ml

@@ -173,7 +173,7 @@ let to_michelson_restrict : t -> Michelson.t result = fun e ->
   match e with
   | [] -> simple_fail "Restrict empty env"
   | Empty :: _ -> ok @@ Michelson.i_comment "restrict empty"
-  | _ -> ok @@ Michelson.i_cdr
+  | _ -> ok @@ Michelson.(seq [i_comment "restrict" ; i_cdr])
   (* Michelson.i_cdr *)
 
 let to_ty = Compiler_type.Ty.environment
@@ -225,25 +225,19 @@ let path_to_michelson_set = fun path ->
 let to_michelson_anonymous_add (t:t) =
   let%bind code = match t with
     | [] -> simple_fail "Schema.Big.Add.to_michelson_add"
-    | [hd] -> Small.to_michelson_append hd
+    | [hd] ->
-    | Empty :: _ -> ok @@ Michelson.i_pair
+        let%bind small = Small.to_michelson_append hd in
+        ok Michelson.(seq [i_comment "big.small add" ; small])
+    | Empty :: _ -> ok @@ Michelson.(seq [i_comment "empty_add" ; i_pair])
     | hd :: _ -> (
         let%bind code = Small.to_michelson_append hd in
-        ok @@ Michelson.(seq [dip i_unpair ; code ; i_pair])
+        ok @@ Michelson.(seq [i_comment "big add" ; dip i_unpair ; code ; i_pair])
       )
   in
   ok code
 
 let to_michelson_add x (t:t) =
-  let%bind code = match t with
+  let%bind code = to_michelson_anonymous_add t in
-    | [] -> simple_fail "Schema.Big.Add.to_michelson_add"
-    | [hd] -> Small.to_michelson_append hd
-    | Empty :: _ -> ok @@ Michelson.i_pair
-    | hd :: _ -> (
-        let%bind code = Small.to_michelson_append hd in
-        ok @@ Michelson.(seq [dip i_unpair ; code ; i_pair])
-      )
-  in
 
   let%bind _assert_type =
     let new_schema = add x t in
@@ -267,20 +261,6 @@ let to_michelson_add x (t:t) =
   ok code
 
 let to_michelson_get (s:t) str : (Michelson.t * type_value) result =
-  (* let open Michelson in
-   * let rec aux s str : (Michelson.t * type_value) result  = match s with
-   *   | [] -> simple_fail "Schema.Big.get"
-   *   | [a] -> Small.to_michelson_get str a
-   *   | a :: b -> (
-   *       match Small.to_michelson_get str a with
-   *       | Trace.Ok (code, tv) -> ok (seq [i_car ; code], tv)
-   *       | Errors _ ->
-   *           let%bind (code, tv) = aux b str in
-   *           ok (seq [i_cdr ; code], tv)
-   *     )
-   * in
-   * let%bind (code, tv) = aux s str in *)
-
   let%bind (path, tv) = get_path str s in
   let code = path_to_michelson_get path in
 
@@ -307,21 +287,6 @@ let to_michelson_get (s:t) str : (Michelson.t * type_value) result =
   ok (code, tv)
 
 let to_michelson_set str (s:t) : Michelson.t result =
-  (* let open Michelson in
-   * let rec aux s str : (Michelson.t * type_value) result =
-   *   match s with
-   *   | [] -> simple_fail "Schema.Big.get"
-   *   | [a] -> Small.to_michelson_set str a
-   *   | a :: b -> (
-   *       match Small.to_michelson_set str a with
-   *       | Trace.Ok (code, tv) -> ok (seq [dip i_unpair ; code ; i_pair], tv)
-   *       | Errors _ ->
-   *           let%bind (tmp, tv) = aux b str in
-   *           ok (seq [dip i_unpiar ; tmp ; i_piar], tv)
-   *     )
-   * in
-   * let%bind (code, tv) = aux s str in *)
-
   let%bind (path, tv) = get_path str s in
   let code = path_to_michelson_set path in
 

src/ligo/mini_c/types.ml

@@ -72,11 +72,12 @@ and assignment = var_name * expression
 and statement' =
   | S_environment_extend
   | S_environment_restrict
+  | S_environment_add of (var_name * type_value)
   | S_declaration of assignment (* First assignment *)
   | S_assignment of assignment
   | S_cond of expression * block * block
   | S_patch of string * [`Left | `Right] list * expression
-  | S_if_none of expression * block * (var_name * block)
+  | S_if_none of expression * block * ((var_name * type_value) * block)
   | S_while of expression * block
 
 and statement = statement' * environment_wrap

src/ligo/test/integration_tests.ml

@@ -404,7 +404,8 @@ let matching () : unit result =
       let%bind result' =
         trace (simple_error "bad result") @@
         get_a_int result in
-      Assert.assert_equal_int (match n with None -> 23 | Some s -> s) result'
+      Assert.assert_equal_int 23 result'
+      (* Assert.assert_equal_int (match n with None -> 23 | Some s -> s) result' *)
     in
     let%bind _ = bind_list
       @@ List.map aux

src/ligo/transpiler.ml

@@ -147,27 +147,24 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
   | I_matching (expr, m) -> (
       let%bind expr' = translate_annotated_expression env expr in
       let env' = Environment.extend env in
-      let aux : block -> block = fun (lst, wrap) -> (* Takes a block and add a "restrict" statement at its end *)
+      let extend s =
-        let b_wrap = { wrap with post_environment = env } in
+        let pre = Combinators.statement S_environment_extend env in
-        let s_wrap = {
+        ok [ pre ; (s, environment_wrap env env) ] in
-          pre_environment = wrap.post_environment ;
+      let restrict : block -> block = fun b -> Combinators.append_statement' b S_environment_restrict in
-          post_environment = env ;
-        } in
-        (lst @ [S_environment_restrict, s_wrap], b_wrap)
-      in
       match m with
       | Match_bool {match_true ; match_false} -> (
           let%bind true_branch = translate_block env' match_true in
           let%bind false_branch = translate_block env' match_false in
-          return (S_cond (expr', aux true_branch, aux false_branch))
+          extend @@ S_cond (expr', restrict true_branch, restrict false_branch)
         )
       | Match_option {match_none ; match_some = ((name, t), sm)} -> (
           let%bind none_branch = translate_block env' match_none in
+          let%bind t' = translate_type t in
           let%bind some_branch =
-            let%bind t' = translate_type t in
+            let env'' = Environment.add (name, t') env' in
-            let env' = Environment.add (name, t') env' in
+            translate_block env'' sm
-            translate_block env' sm in
+          in
-          return (S_if_none (expr', aux none_branch, (name, aux some_branch)))
+          extend (S_if_none (expr', restrict none_branch, ((name, t'), restrict some_branch)))
         )
       | _ -> simple_fail "todo : match"
     )