diff --git a/src/lib_utils/x_list.ml b/src/lib_utils/x_list.ml index 9d0d0135e..e0e1d4732 100644 --- a/src/lib_utils/x_list.ml +++ b/src/lib_utils/x_list.ml @@ -7,6 +7,8 @@ let map ?(acc = []) f lst = in aux acc f (List.rev lst) +let fold_right' f init lst = List.fold_left f init (List.rev lst) + let filter_map f = let rec aux acc lst = match lst with | [] -> List.rev acc diff --git a/src/ligo/mini_c/compiler.ml b/src/ligo/mini_c/compiler.ml index c821c7181..50beba2a1 100644 --- a/src/ligo/mini_c/compiler.ml +++ b/src/ligo/mini_c/compiler.ml @@ -327,29 +327,17 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = let%bind expr = translate_expression expr in let%bind a' = translate_regular_block a in let%bind b' = translate_regular_block b in - let%bind restrict_a = - let env_a = (snd a).pre_environment in - Environment.to_michelson_restrict env_a in - let%bind restrict_b = - let env_b = (snd b).pre_environment in - Environment.to_michelson_restrict env_b in ok @@ (seq [ i_push_unit ; expr ; prim I_CAR ; dip @@ Environment.to_michelson_extend w_env.pre_environment ; - prim ~children:[seq [a' ; restrict_a];seq [b' ; restrict_b]] I_IF ; + prim ~children:[seq [a'];seq [b']] I_IF ; ]) | S_if_none (expr, none, (_, 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 restrict_none = - let env_none = (snd none).pre_environment in - Environment.to_michelson_restrict env_none in - let%bind restrict_some = - let env_some = (snd some).pre_environment in - Environment.to_michelson_restrict env_some in let%bind add = let env = Environment.extend w_env.pre_environment in Environment.to_michelson_anonymous_add env in @@ -357,8 +345,8 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = i_push_unit ; expr ; i_car ; dip @@ Environment.to_michelson_extend w_env.pre_environment ; prim ~children:[ - seq [none' ; restrict_none] ; - seq [add ; some' ; restrict_some] ; + seq [none'] ; + seq [add ; some'] ; ] I_IF_NONE ]) | S_while ((_, _, _) as expr, block) -> diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index ff103f925..82ff5d5e9 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -147,11 +147,19 @@ 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 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', true_branch, false_branch)) + return (S_cond (expr', aux true_branch, aux false_branch)) ) | Match_option {match_none ; match_some = ((name, t), sm)} -> ( let%bind none_branch = translate_block env' match_none in @@ -159,7 +167,7 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li 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', none_branch, (name, some_branch))) + return (S_if_none (expr', aux none_branch, (name, aux some_branch))) ) | _ -> simple_fail "todo : match" ) @@ -238,29 +246,6 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express let%bind tpl' = translate_annotated_expression env tpl in let expr = List.fold_left aux tpl' path in ok expr - (* let%bind tpl' = translate_annotated_expression env tpl in - * let%bind tpl_tv = get_t_tuple tpl.type_annotation in - * let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (i, a)) tpl_tv in - * let leaf (i, _) : expression result = - * if i = ind then ( - * ok tpl' - * ) else ( - * simple_fail "bad leaf" - * ) in - * let node a b : expression result = - * match%bind bind_lr (a, b) with - * | `Left ((_, t, env) as ex) -> ( - * let%bind (a, _) = get_t_pair t in - * ok (E_constant ("CAR", [ex]), a, env) - * ) - * | `Right ((_, t, env) as ex) -> ( - * let%bind (_, b) = get_t_pair t in - * ok (E_constant ("CDR", [ex]), b, env) - * ) in - * let%bind expr = - * trace_strong (simple_error "bad index in tuple (shouldn't happen here)") @@ - * Append_tree.fold_ne leaf node node_tv in - * ok expr *) | E_record m -> let node = Append_tree.of_list @@ list_of_map m in let aux a b : expression result =