fixed minor bug
This commit is contained in:
parent
d9afee0fad
commit
be75fd4830
@ -12,8 +12,9 @@
|
||||
ast_typed
|
||||
transpiler
|
||||
mini_c
|
||||
operators
|
||||
compiler
|
||||
self_michelson
|
||||
operators
|
||||
)
|
||||
(preprocess
|
||||
(pps ppx_let)
|
||||
|
@ -8,11 +8,13 @@ let compile_value : value -> type_value -> Michelson.t result =
|
||||
let compile_expression_as_value : expression -> _ result = fun e ->
|
||||
let%bind value = expression_to_value e in
|
||||
let%bind result = compile_value value e.type_value in
|
||||
let%bind result = Self_michelson.all_expression result in
|
||||
ok result
|
||||
|
||||
let compile_expression_as_function : expression -> _ result = fun e ->
|
||||
let (input , output) = t_unit , e.type_value in
|
||||
let%bind body = Compiler.Program.translate_expression e Compiler.Environment.empty in
|
||||
let%bind body = Self_michelson.all_expression body in
|
||||
let body = Michelson.(seq [ i_drop ; body ]) in
|
||||
let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in
|
||||
let open! Compiler.Program in
|
||||
@ -22,13 +24,11 @@ let compile_function = fun e ->
|
||||
let%bind (input , output) = get_t_function e.type_value in
|
||||
let%bind body = get_function e in
|
||||
let%bind body = compile_value body (t_function input output) in
|
||||
let%bind body = Self_michelson.all_expression body in
|
||||
let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in
|
||||
let open! Compiler.Program in
|
||||
ok { input ; output ; body }
|
||||
|
||||
(* let compile_function : anon_function -> (type_value * type_value) -> Compiler.Program.compiled_program result = fun f io ->
|
||||
* Compiler.Program.translate_entry f io *)
|
||||
|
||||
let compile_expression_as_function_entry = fun program name ->
|
||||
let%bind aggregated = aggregate_entry program name true in
|
||||
compile_function aggregated
|
||||
|
12
src/passes/9-self_michelson/dune
Normal file
12
src/passes/9-self_michelson/dune
Normal file
@ -0,0 +1,12 @@
|
||||
(library
|
||||
(name self_michelson)
|
||||
(public_name ligo.self_michelson)
|
||||
(libraries
|
||||
simple-utils
|
||||
tezos-utils
|
||||
)
|
||||
(preprocess
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
|
||||
)
|
19
src/passes/9-self_michelson/helpers.ml
Normal file
19
src/passes/9-self_michelson/helpers.ml
Normal file
@ -0,0 +1,19 @@
|
||||
open Trace
|
||||
open Tezos_utils
|
||||
open Michelson
|
||||
open Tezos_micheline.Micheline
|
||||
|
||||
type mapper = michelson -> michelson result
|
||||
let rec map_expression : mapper -> michelson -> michelson result = fun f e ->
|
||||
let self = map_expression f in
|
||||
let%bind e' = f e in
|
||||
match e' with
|
||||
| Prim (l , p , lst , a) -> (
|
||||
let%bind lst' = bind_map_list self lst in
|
||||
ok @@ Prim (l , p , lst' , a)
|
||||
)
|
||||
| Seq (l , lst) -> (
|
||||
let%bind lst' = bind_map_list self lst in
|
||||
ok @@ Seq (l , lst')
|
||||
)
|
||||
| x -> ok x
|
0
src/passes/9-self_michelson/main.ml
Normal file
0
src/passes/9-self_michelson/main.ml
Normal file
31
src/passes/9-self_michelson/self_michelson.ml
Normal file
31
src/passes/9-self_michelson/self_michelson.ml
Normal file
@ -0,0 +1,31 @@
|
||||
open Trace
|
||||
open Tezos_micheline.Micheline
|
||||
open Memory_proto_alpha.Protocol.Michelson_v1_primitives
|
||||
|
||||
let strip_annots = fun e ->
|
||||
match e with
|
||||
| Prim (l , p , lst , _) -> ok @@ Prim (l , p , lst , [])
|
||||
| x -> ok x
|
||||
|
||||
let strip_nops = fun e ->
|
||||
match e with
|
||||
| Seq(l, [Prim (_, I_UNIT, _, _) ; Prim(_, I_DROP, _, _)]) -> ok @@ Seq (l, [])
|
||||
| x -> ok x
|
||||
|
||||
|
||||
let all = [
|
||||
strip_annots ;
|
||||
strip_nops ;
|
||||
]
|
||||
|
||||
let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x ->
|
||||
match fs with
|
||||
| [] -> ok x
|
||||
| hd :: tl -> (
|
||||
let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in
|
||||
bind aux (ok x)
|
||||
)
|
||||
|
||||
let all_expression =
|
||||
let all_expr = List.map Helpers.map_expression all in
|
||||
bind_chain all_expr
|
Loading…
Reference in New Issue
Block a user