From 126b62b18e4a34b110e13335d38e6e9a564f928a Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 15 Apr 2019 17:42:06 +0000 Subject: [PATCH] better mini_c instructions --- src/ligo/contracts/match.ligo | 2 +- src/ligo/mini_c/PP.ml | 3 +- src/ligo/mini_c/combinators.ml | 16 ++++++++ src/ligo/mini_c/compiler.ml | 14 ++++--- src/ligo/mini_c/compiler_environment.ml | 49 ++++--------------------- src/ligo/mini_c/types.ml | 3 +- src/ligo/test/integration_tests.ml | 3 +- src/ligo/transpiler.ml | 23 +++++------- 8 files changed, 48 insertions(+), 65 deletions(-) diff --git a/src/ligo/contracts/match.ligo b/src/ligo/contracts/match.ligo index 06e1fe4d8..32ea91625 100644 --- a/src/ligo/contracts/match.ligo +++ b/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 diff --git a/src/ligo/mini_c/PP.ml b/src/ligo/mini_c/PP.ml index 824954280..c4f8b448d 100644 --- a/src/ligo/mini_c/PP.ml +++ b/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) = diff --git a/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml index 5651edc53..915f2fc87 100644 --- a/src/ligo/mini_c/combinators.ml +++ b/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 | [] -> [] diff --git a/src/ligo/mini_c/compiler.ml b/src/ligo/mini_c/compiler.ml index 50beba2a1..8c4c7b6bd 100644 --- a/src/ligo/mini_c/compiler.ml +++ b/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 - Environment.to_michelson_anonymous_add env in + let env' = Environment.extend w_env.pre_environment 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 diff --git a/src/ligo/mini_c/compiler_environment.ml b/src/ligo/mini_c/compiler_environment.ml index 29ebe52ab..f50cdbb16 100644 --- a/src/ligo/mini_c/compiler_environment.ml +++ b/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 - | Empty :: _ -> ok @@ Michelson.i_pair + | [hd] -> + 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 - | [] -> 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 code = to_michelson_anonymous_add t 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 diff --git a/src/ligo/mini_c/types.ml b/src/ligo/mini_c/types.ml index c0b30d5d1..4e8baeaa3 100644 --- a/src/ligo/mini_c/types.ml +++ b/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 diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 26df37072..c36d27c26 100644 --- a/src/ligo/test/integration_tests.ml +++ b/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 diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index 82ff5d5e9..742d09161 100644 --- a/src/ligo/transpiler.ml +++ b/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 b_wrap = { wrap with post_environment = env } in - let s_wrap = { - pre_environment = wrap.post_environment ; - post_environment = env ; - } in - (lst @ [S_environment_restrict, s_wrap], b_wrap) - in + let extend s = + let pre = Combinators.statement S_environment_extend env in + ok [ pre ; (s, environment_wrap env env) ] in + let restrict : block -> block = fun b -> Combinators.append_statement' b S_environment_restrict 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 - translate_block env' sm in - return (S_if_none (expr', aux none_branch, (name, aux some_branch))) + let env'' = Environment.add (name, t') env' in + translate_block env'' sm + in + extend (S_if_none (expr', restrict none_branch, ((name, t'), restrict some_branch))) ) | _ -> simple_fail "todo : match" )