remove statements from mini_c
This commit is contained in:
Galfour
parent
2a091edbc0
commit
46d07c55ea
@ -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 =
|
and translate_quote_body ({result ; binder ; input} as f:anon_function) : michelson result =
|
||||||
let env = Environment.(add (binder , input) empty) in
|
let env = Environment.(add (binder , input) empty) in
|
||||||
let%bind (expr , _) = translate_expression result env in
|
let%bind (expr , _) = translate_expression result env in
|
||||||
|
|||||||
@ -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 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 "{@; @[<v>%a@]@;}" (pp_print_list ~pp_sep:(tag "@;") statement) b
|
|
||||||
|
|
||||||
let tl_statement ppf (ass, _) = assignment ppf ass
|
let tl_statement ppf (ass, _) = assignment ppf ass
|
||||||
|
|
||||||
let program ppf (p:program) =
|
let program ppf (p:program) =
|
||||||
|
|||||||
@ -121,12 +121,6 @@ let get_operation (v:value) = match v with
|
|||||||
| _ -> simple_fail "not an operation"
|
| _ -> 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_int : type_value = T_base Base_int
|
||||||
let t_unit : type_value = T_base Base_unit
|
let t_unit : type_value = T_base Base_unit
|
||||||
let t_nat : type_value = T_base Base_nat
|
let t_nat : type_value = T_base Base_nat
|
||||||
|
|||||||
@ -1,52 +1,6 @@
|
|||||||
open Trace
|
|
||||||
open Types
|
open Types
|
||||||
open Combinators
|
open Combinators
|
||||||
|
|
||||||
let basic_int_quote_env : environment =
|
let basic_int_quote_env : environment =
|
||||||
let e = Environment.empty in
|
let e = Environment.empty in
|
||||||
Environment.add ("input", t_int) e
|
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
|
|
||||||
|
|||||||
@ -81,20 +81,6 @@ and expression = {
|
|||||||
|
|
||||||
and assignment = var_name * 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 toplevel_statement = assignment * environment_wrap
|
||||||
|
|
||||||
and anon_function = {
|
and anon_function = {
|
||||||
@ -104,8 +90,4 @@ and anon_function = {
|
|||||||
result : expression ;
|
result : expression ;
|
||||||
}
|
}
|
||||||
|
|
||||||
and block' = statement list
|
|
||||||
|
|
||||||
and block = block' * environment_wrap
|
|
||||||
|
|
||||||
and program = toplevel_statement list
|
and program = toplevel_statement list
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user