balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

remove statements from mini_c

Browse Source
This commit is contained in:
Galfour 2019-05-20 16:26:55 +00:00
parent 2a091edbc0
commit 46d07c55ea
5 changed files with 0 additions and 263 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

175
src/compiler/compiler_program.ml
View File

@ -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

18
src/mini_c/PP.ml
View File

@ -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 "{@; @[<v>%a@]@;}" (pp_print_list ~pp_sep:(tag "@;") statement) b
let tl_statement ppf (ass, _) = assignment ppf ass
let program ppf (p:program) =

6
src/mini_c/combinators.ml
View File

@ -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

46
src/mini_c/combinators_smart.ml
View File

@ -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

18
src/mini_c/types.ml
View File

@ -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