From 46d07c55ead9e7d4771a88421ed9a46eefb05d37 Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 20 May 2019 16:26:55 +0000 Subject: [PATCH] remove statements from mini_c --- src/compiler/compiler_program.ml | 175 ------------------------------- src/mini_c/PP.ml | 18 ---- src/mini_c/combinators.ml | 6 -- src/mini_c/combinators_smart.ml | 46 -------- src/mini_c/types.ml | 18 ---- 5 files changed, 263 deletions(-) diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index 141c7d54c..077e8f92f 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -395,181 +395,6 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m ] ) -and translate_statement ((s', w_env) as s:statement) : michelson result = - let error_message () = Format.asprintf "%a" PP.statement s in - let return code = - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment w_env.pre_environment in - let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment w_env.post_environment in - let error_message () = - let%bind pre_env_michelson = Compiler_type.environment w_env.pre_environment in - let%bind post_env_michelson = Compiler_type.environment w_env.post_environment in - ok @@ Format.asprintf - "statement : %a\ncode : %a\npre type : %a\npost type : %a\n" - PP.statement s - Michelson.pp code - PP_helpers.(list_sep Michelson.pp (const " ; ")) pre_env_michelson - PP_helpers.(list_sep Michelson.pp (const " ; ")) post_env_michelson - in - let%bind _ = - Trace.trace_tzresult_lwt_r (fun () -> let%bind error_message = error_message () in - ok (fun () -> error (thunk "error parsing statement code") - (fun () -> error_message) - ())) @@ - Proto_alpha_utils.Memory_proto_alpha.parse_michelson_fail code - input_stack_ty output_stack_ty - in - ok code - in - - trace (fun () -> error (thunk "compiling statement") error_message ()) @@ match s' with - | S_environment_add _ -> - simple_fail "add not ready yet" - | S_environment_select sub_env -> - let%bind code = Compiler_environment.select_env w_env.pre_environment sub_env in - return code - | S_environment_load (expr , env) -> - let%bind (expr' , _) = translate_expression expr w_env.pre_environment in - let%bind clear = Compiler_environment.select w_env.pre_environment [] in - let%bind unpack = Compiler_environment.unpack env in - return @@ seq [ - expr' ; - dip clear ; - unpack ; - ] - | S_declaration (s, expr) -> - let tv = Combinators.Expression.get_type expr in - let%bind (expr , _) = translate_expression expr w_env.pre_environment in - let%bind add = Compiler_environment.add w_env.pre_environment (s, tv) in - return @@ seq [ - i_comment "declaration" ; - seq [ - i_comment "expr" ; - expr ; - ] ; - seq [ - i_comment "env <- env . expr" ; - add ; - ]; - ] - | S_assignment (s, expr) -> - let%bind (expr , _) = translate_expression expr w_env.pre_environment in - let%bind set = Compiler_environment.set w_env.pre_environment s in - return @@ seq [ - i_comment "assignment" ; - seq [ - i_comment "expr" ; - expr ; - ] ; - seq [ - i_comment "env <- env . expr" ; - set ; - ]; - ] - | S_cond (expr, a, b) -> - let%bind (expr , _) = translate_expression expr w_env.pre_environment in - let%bind a' = translate_regular_block a in - let%bind b' = translate_regular_block b in - return @@ seq [ - expr ; - prim ~children:[seq [a'];seq [b']] I_IF ; - ] - | S_do expr -> ( - match Combinators.Expression.get_content expr with - | E_constant ("FAILWITH" , [ fw ] ) -> ( - let%bind (fw' , _) = translate_expression fw w_env.pre_environment in - return @@ seq [ - fw' ; - i_failwith ; - ] - ) - | _ -> ( - let%bind (expr' , _) = translate_expression expr w_env.pre_environment in - return @@ seq [ - expr' ; - i_drop ; - ] - ) - ) - | S_if_none (expr, none, ((name, tv), some)) -> - let%bind (expr , _) = translate_expression expr w_env.pre_environment in - let%bind none' = translate_regular_block none in - let%bind some' = translate_regular_block some in - let%bind add = - let env' = w_env.pre_environment in - Compiler_environment.add env' (name, tv) in - let%bind restrict_s = Compiler_environment.select_env (snd some).post_environment w_env.pre_environment in - return @@ seq [ - expr ; - prim ~children:[ - seq [none'] ; - seq [add ; some' ; restrict_s] ; - ] I_IF_NONE - ] - | S_while (expr, block) -> - let%bind (expr , _) = translate_expression expr w_env.pre_environment in - let%bind block' = translate_regular_block block in - let%bind restrict_block = - let env_while = (snd block).pre_environment in - Compiler_environment.select_env (snd block).post_environment env_while in - return @@ seq [ - expr ; - prim ~children:[seq [ - block' ; - restrict_block ; - expr]] I_LOOP ; - ] - | S_patch (name, lrs, expr) -> - let%bind (expr' , env') = translate_expression expr w_env.pre_environment in - let%bind get_code = Compiler_environment.get env' name in - let modify_code = - let aux acc step = match step with - | `Left -> seq [dip i_unpair ; acc ; i_pair] - | `Right -> seq [dip i_unpiar ; acc ; i_piar] - in - let init = dip i_drop in - List.fold_right' aux init lrs - in - let%bind set_code = Compiler_environment.set w_env.pre_environment name in - let error = - let title () = "michelson type-checking patch" in - let content () = - let aux ppf = function - | `Left -> Format.fprintf ppf "left" - | `Right -> Format.fprintf ppf "right" in - Format.asprintf "Sub path: %a\n" - PP_helpers.(list_sep aux (const " , ")) lrs - in - error title content in - trace error @@ - return @@ seq [ - expr' ; - get_code ; - i_swap ; modify_code ; - set_code ; - ] - -and translate_regular_block ((b, env):block) : michelson result = - let aux prev statement = - let%bind (lst : michelson list) = prev in - let%bind instruction = translate_statement statement in - ok (instruction :: lst) - in - let%bind codes = - let error_message () = - let%bind schema_michelsons = Compiler_type.environment env.pre_environment in - ok @@ Format.asprintf "\nblock : %a\nschema : %a\n" - PP.block (b, env) - PP_helpers.(list_sep Michelson.pp (const " ; ")) schema_michelsons - in - trace_r (fun () -> - let%bind error_message = error_message () in - ok (fun () -> error (thunk "compiling regular block") - (fun () -> error_message) - ())) @@ - List.fold_left aux (ok []) b in - let code = seq (List.rev codes) in - ok code - and translate_quote_body ({result ; binder ; input} as f:anon_function) : michelson result = let env = Environment.(add (binder , input) empty) in let%bind (expr , _) = translate_expression result env in diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 972707548..a7fb12d6c 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -105,24 +105,6 @@ and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expression e -and statement ppf ((s, _) : statement) = match s with - | S_environment_load _ -> fprintf ppf "load env" - | S_environment_select _ -> fprintf ppf "select env" - | 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_do e -> fprintf ppf "do %a" expression e - | S_cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e - | S_patch (r, path, e) -> - fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) 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_while (e, b) -> fprintf ppf "while (%a) %a" expression e block b - -and block ppf ((b, _):block) = - match b with - | [] -> fprintf ppf "{}" - | b -> fprintf ppf "{@; @[%a@]@;}" (pp_print_list ~pp_sep:(tag "@;") statement) b - let tl_statement ppf (ass, _) = assignment ppf ass let program ppf (p:program) = diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index d4528b24e..670d63e5f 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -121,12 +121,6 @@ let get_operation (v:value) = match v with | _ -> simple_fail "not an operation" -let get_last_statement ((b', _):block) : statement result = - let aux lst = match lst with - | [] -> simple_fail "get_last: empty list" - | lst -> ok List.(nth lst (length lst - 1)) in - aux b' - let t_int : type_value = T_base Base_int let t_unit : type_value = T_base Base_unit let t_nat : type_value = T_base Base_nat diff --git a/src/mini_c/combinators_smart.ml b/src/mini_c/combinators_smart.ml index 4e0126f35..6cffd7226 100644 --- a/src/mini_c/combinators_smart.ml +++ b/src/mini_c/combinators_smart.ml @@ -1,52 +1,6 @@ -open Trace open Types open Combinators let basic_int_quote_env : environment = let e = Environment.empty in Environment.add ("input", t_int) e - -let statement s' env : statement = - match s' with - | S_environment_load (_ , env') -> s', environment_wrap env env' - | S_environment_select env' -> s', environment_wrap env env' - | S_environment_add (name, tv) -> s' , environment_wrap env (Environment.add (name , tv) env) - | S_cond _ -> s' , id_environment_wrap env - | S_do _ -> s' , id_environment_wrap env - | S_if_none _ -> s' , id_environment_wrap env - | S_while _ -> s' , id_environment_wrap env - | S_patch _ -> s' , id_environment_wrap env - | S_declaration (name , e) -> s', environment_wrap env (Environment.add (name , (Expression.get_type e)) env) - | S_assignment (name , e) -> s', environment_wrap env (Environment.add (name , (Expression.get_type e)) env) - -let block (statements:statement list) : block result = - match statements with - | [] -> simple_fail "no statements in block" - | lst -> - let first = List.hd lst in - 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 - | [] -> [] - | hd :: tl -> - let s = hd e in - s :: aux tl (snd s).post_environment - in - aux lst e diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index b3f33be6b..ca445ee0e 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -81,20 +81,6 @@ and expression = { and assignment = var_name * expression -and statement' = - | S_environment_select of environment - | S_environment_load of (expression * environment) - | S_environment_add of (var_name * type_value) - | S_declaration of assignment (* First assignment *) - | S_assignment of assignment - | S_do of expression - | S_cond of expression * block * block - | S_patch of string * [`Left | `Right] list * expression - | S_if_none of expression * block * ((var_name * type_value) * block) - | S_while of expression * block - -and statement = statement' * environment_wrap - and toplevel_statement = assignment * environment_wrap and anon_function = { @@ -104,8 +90,4 @@ and anon_function = { result : expression ; } -and block' = statement list - -and block = block' * environment_wrap - and program = toplevel_statement list