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

close to finishing

Browse Source
This commit is contained in:
Galfour 2019-05-05 13:05:32 +00:00
parent fe79b2bcf6
commit c5aab2cf85
12 changed files with 283 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/lib_utils/PP.ml
View File

@ -2,6 +2,7 @@ open Format
let string : formatter -> string -> unit = fun ppf s -> fprintf ppf "%s" s
let tag tag : formatter -> unit -> unit = fun ppf () -> fprintf ppf tag
let bool ppf b = fprintf ppf "%b" b
let pair f g ppf (a , b) = fprintf ppf "%a , %a" f a g b
let new_line : formatter -> unit -> unit = tag "@;"
let rec new_lines n ppf () =
match n with

10
src/lib_utils/trace.ml
View File

@ -189,6 +189,16 @@ let bind_fold_map_list = fun f acc lst ->
aux (acc , []) f lst >>? fun (_acc' , lst') ->
ok @@ List.rev lst'
let bind_fold_map_right_list = fun f acc lst ->
let rec aux (acc , prev) f = function
| [] -> ok (acc , prev)
| hd :: tl ->
f acc hd >>? fun (acc' , hd') ->
aux (acc' , hd' :: prev) f tl
in
aux (acc , []) f (List.rev lst) >>? fun (_acc' , lst') ->
ok lst'
let bind_fold_right_list f init lst =
let aux x y =
x >>? fun x ->

18
src/lib_utils/x_list.ml
View File

@ -7,7 +7,7 @@ let map ?(acc = []) f lst =
in
aux acc f (List.rev lst)
let fold_map : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> ret list =
let fold_map_right : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> ret list =
fun f acc lst ->
let rec aux (acc , prev) f = function
| [] -> (acc , prev)
@ -17,8 +17,24 @@ let fold_map : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list
in
snd @@ aux (acc , []) f (List.rev lst)
let fold_map : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> ret list =
fun f acc lst ->
let rec aux (acc , prev) f = function
| [] -> (acc , prev)
| hd :: tl ->
let (acc' , hd') = f acc hd in
aux (acc' , hd' :: prev) f tl
in
List.rev @@ snd @@ aux (acc , []) f lst
let fold_right' f init lst = List.fold_left f init (List.rev lst)
let rec remove_element x lst =
match lst with
| [] -> raise (Failure "X_list.remove_element")
| hd :: tl when x = hd -> tl
| hd :: tl -> hd :: remove_element x tl
let filter_map f =
let rec aux acc lst = match lst with
| [] -> List.rev acc

6
src/lib_utils/x_tezos_micheline.ml
View File

@ -54,9 +54,9 @@ module Michelson = struct
let i_drop = prim I_DROP
let i_exec = prim I_EXEC
let i_if a b = prim ~children:[a;b] I_IF
let i_if_none a b = prim ~children:[a;b] I_IF_NONE
let i_if_left a b = prim ~children:[a;b] I_IF_LEFT
let i_if a b = prim ~children:[seq [a] ; seq[b]] I_IF
let i_if_none a b = prim ~children:[seq [a] ; seq[b]] I_IF_NONE
let i_if_left a b = prim ~children:[seq [a] ; seq[b]] I_IF_LEFT
let i_failwith = prim I_FAILWITH
let i_assert_some = i_if_none (seq [i_push_string "ASSERT_SOME" ; i_failwith]) (seq [])
let i_assert_some_msg msg = i_if_none (seq [msg ; i_failwith]) (seq [])

127
src/ligo/compiler/compiler_environment.ml
View File

@ -87,22 +87,44 @@ let add : environment -> (string * type_value) -> michelson result = fun e (_s ,
ok code
let select : environment -> string list -> michelson result = fun e lst ->
let module L = Logger.Stateful() in
let e_lst =
let e_lst = Environment.to_list e in
let aux selector (s , _) =
L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ;
match List.mem s selector with
| true -> List.remove_element s selector , true
| false -> selector , false in
let e_lst' = List.fold_map_right aux lst e_lst in
let e_lst'' = List.combine e_lst e_lst' in
e_lst'' in
let code =
let aux = fun acc (s , _) ->
seq [
dip acc ;
if List.mem s lst
then seq []
else i_drop ;
]
let aux = fun code (_ , b) ->
match b with
| false -> seq [dip code ; i_drop]
| true -> dip code
in
Environment.fold aux (seq []) e in
List.fold_right' aux (seq []) e_lst in
let%bind () =
let error () = ok @@ simple_error "error producing Env.select" in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let e' = Environment.filter (fun (s , _) -> List.mem s lst) e in
let e' =
Environment.of_list
@@ List.map fst
@@ List.filter snd
@@ e_lst
in
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e' in
let error () =
let title () = "error producing Env.select" in
let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n"
PP.environment e
PP.environment e'
PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst
Micheline.Michelson.pp code
(L.get ())
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
@ -117,3 +139,88 @@ let clear : environment -> michelson result = fun e -> select e []
let select_env : environment -> environment -> michelson result = fun e e' ->
let lst = Environment.get_names e' in
select e lst
let pack : environment -> michelson result = fun e ->
let%bind () =
trace_strong (simple_error "pack empty env") @@
Assert.assert_true (List.length e <> 0) in
ok @@ seq @@ List.map (Function.constant i_pair) @@ List.tl e
let unpack : environment -> michelson result = fun e ->
let%bind () =
trace_strong (simple_error "unpack empty env") @@
Assert.assert_true (List.length e <> 0) in
ok @@ seq @@ List.map (Function.constant i_unpair) @@ List.tl e
let pack_select : environment -> string list -> michelson result = fun e lst ->
let module L = Logger.Stateful() in
let e_lst =
let e_lst = Environment.to_list e in
let aux selector (s , _) =
L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ;
match List.mem s selector with
| true -> List.remove_element s selector , true
| false -> selector , false in
let e_lst' = List.fold_map_right aux lst e_lst in
let e_lst'' = List.combine e_lst e_lst' in
e_lst'' in
let (_ , code) =
let aux = fun (first , code) (_ , b) ->
match b with
| false -> (first , seq [dip code ; i_swap])
| true -> (false ,
match first with
| true -> i_dup
| false -> seq [dip code ; i_dup ; dip i_pair ; i_swap]
)
in
List.fold_right' aux (true , seq []) e_lst in
let%bind () =
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let e' =
Environment.of_list
@@ List.map fst
@@ List.filter snd
@@ e_lst
in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in
let output_stack_ty = Stack.(output_ty @: input_stack_ty) in
let error () =
let title () = "error producing Env.pack_select" in
let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n"
PP.environment e
PP.environment e'
PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst
Micheline.Michelson.pp code
(L.get ())
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let add_packed_anon : environment -> type_value -> michelson result = fun e type_value ->
let code = i_pair in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Ex_ty input_ty) = Compiler_type.Ty.environment_representation e in
let e' = Environment.add ("_add_packed_anon" , type_value) e in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: input_ty @: nil) in
let output_stack_ty = Stack.(output_ty @: nil) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code

104
src/ligo/compiler/compiler_program.ml
View File

@ -71,17 +71,16 @@ and translate_function (content:anon_function) : michelson result =
ok @@ seq [ body ]
and translate_expression ?(first=false) (expr:expression) (env:environment) : (michelson * environment) result =
let (expr' , ty , _) = Combinators.Expression.(get_content expr , get_type expr , get_environment expr) in
let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in
let error_message () = Format.asprintf "%a" PP.expression expr in
let return code =
let return ?env' code =
let env' =
let default = env in
Environment.add ("_tmp_expression" , ty) @@ Option.unopt ~default env' in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in
let%bind output_type = Compiler_type.type_ ty in
let%bind (Ex_ty output_ty) =
let error_message () = Format.asprintf "%a" Michelson.pp output_type in
Trace.trace_tzresult_lwt (fun () -> error (thunk "error parsing output ty") error_message ()) @@
Tezos_utils.Memory_proto_alpha.parse_michelson_ty output_type in
let output_stack_ty = Stack.(output_ty @: input_stack_ty) in
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in
let error_message () =
let%bind schema_michelsons = Compiler_type.environment env in
ok @@ Format.asprintf
@ -101,13 +100,14 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
Tezos_utils.Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty
in
let env' = Environment.add ("_tmp_expression" , ty) env in
ok (code , env')
in
trace (error (thunk "compiling expression") error_message) @@
match expr' with
| E_capture_environment _c -> simple_fail "capture"
| E_capture_environment c ->
let%bind code = Compiler_environment.pack_select env c in
return @@ code
| E_literal v ->
let%bind v = translate_value v in
let%bind t = Compiler_type.type_ ty in
@ -127,10 +127,11 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
prim I_EXEC ;
]
)
| T_deep_closure (_small_env, _, _) -> (
| T_deep_closure (small_env, input_ty , _) -> (
trace (simple_error "Compiling deep closure application") @@
let%bind (f' , env') = translate_expression ~first f env in
let%bind (arg' , _) = translate_expression arg env' in
let%bind (arg' , env') = translate_expression arg env in
let%bind (f' , _) = translate_expression f env' in
let%bind append_closure = Compiler_environment.add_packed_anon small_env input_ty in
let error =
let error_title () = "michelson type-checking closure application" in
let error_content () =
@ -143,14 +144,10 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
in
trace error @@
return @@ seq [
i_comment "(* unit :: env *)" ;
i_comment "compute arg" ;
arg' ;
i_comment "(* (arg * unit) :: env *)" ;
i_comment "compute closure" ;
dip @@ seq [f' ; i_unpair] ;
i_comment "(* arg :: capture :: f :: unit :: env *)" ;
i_exec ; (* output :: stack :: env *)
f' ; i_unpair ;
dip @@ append_closure ;
i_swap ; i_exec ;
]
)
| _ -> simple_fail "E_applicationing something not appliable"
@ -169,19 +166,24 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
PP.environment env ;
ok (env' , code)
in
bind_fold_map_list aux env lst in
bind_fold_map_right_list aux env lst in
let%bind predicate = get_predicate str ty lst in
let pre_code = seq @@ List.rev lst' in
let%bind code = match (predicate, List.length lst) with
| Constant c, 0 -> ok @@ seq @@ lst' @ [
| Constant c, 0 -> ok @@ seq [
pre_code ;
c ;
]
| Unary f, 1 -> ok @@ seq @@ lst' @ [
| Unary f, 1 -> ok @@ seq [
pre_code ;
f ;
]
| Binary f, 2 -> ok @@ seq @@ lst' @ [
| Binary f, 2 -> ok @@ seq [
pre_code ;
f ;
]
| Ternary f, 3 -> ok @@ seq @@ lst' @ [
| Ternary f, 3 -> ok @@ seq [
pre_code ;
f ;
]
| _ -> simple_fail "bad arity"
@ -207,20 +209,21 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
let%bind (a' , _) = translate_expression a env' in
let%bind (b' , _) = translate_expression b env' in
let%bind code = ok (seq [
c' ; i_unpair ;
c' ;
i_if a' b' ;
]) in
return code
)
| E_if_none (c, n, (_ , s)) -> (
let%bind (c' , env') = translate_expression c env in
let%bind (n' , _) = translate_expression n env' in
let%bind (s' , _) = translate_expression s env' in
let%bind (c' , _env') = translate_expression c env in
let%bind (n' , _) = translate_expression n n.environment in
let%bind (s' , _) = translate_expression s s.environment in
let%bind restrict_s = Compiler_environment.select_env s.environment env in
let%bind code = ok (seq [
c' ; i_unpair ;
c' ;
i_if_none n' (seq [
i_pair ;
s' ;
restrict_s ;
])
;
]) in
@ -229,18 +232,16 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
| E_if_left (c, (_ , l), (_ , r)) -> (
let%bind (c' , _env') = translate_expression c env in
let%bind (l' , _) = translate_expression l l.environment in
let%bind (r' , _) = translate_expression r l.environment in
let%bind (r' , _) = translate_expression r r.environment in
let%bind restrict_l = Compiler_environment.select_env l.environment env in
let%bind restrict_r = Compiler_environment.select_env r.environment env in
let%bind code = ok (seq [
c' ; i_unpair ;
c' ;
i_if_left (seq [
i_swap ; dip i_pair ;
l' ;
i_comment "restrict left" ;
dip restrict_l ;
]) (seq [
i_swap ; dip i_pair ;
r' ;
i_comment "restrict right" ;
dip restrict_r ;
@ -292,12 +293,18 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
trace (fun () -> error (thunk "compiling statement") error_message ()) @@ match s' with
| S_environment_add _ ->
simple_fail "add not ready yet"
| S_environment_select _ ->
simple_fail "select not ready yet"
| S_environment_load _ ->
simple_fail "load not ready yet"
(* | S_environment_add (name, tv) ->
* Environment.to_michelson_add (name, tv) w_env.pre_environment *)
| 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
@ -332,9 +339,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
let%bind a' = translate_regular_block a in
let%bind b' = translate_regular_block b in
return @@ seq [
i_push_unit ;
expr ;
prim I_CAR ;
prim ~children:[seq [a'];seq [b']] I_IF ;
]
| S_do expr -> (
@ -361,11 +366,12 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
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 [
i_push_unit ; expr ; i_car ;
expr ;
prim ~children:[
seq [none'] ;
seq [add ; some'] ;
seq [add ; some' ; restrict_s] ;
] I_IF_NONE
]
| S_while (expr, block) ->
@ -375,15 +381,15 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
let env_while = (snd block).pre_environment in
Compiler_environment.select_env (snd block).post_environment env_while in
return @@ seq [
i_push_unit ; expr ; i_car ;
expr ;
prim ~children:[seq [
block' ;
restrict_block ;
i_push_unit ; expr ; i_car]] I_LOOP ;
expr]] I_LOOP ;
]
| S_patch (name, lrs, expr) ->
let%bind (expr' , _) = translate_expression expr w_env.pre_environment in
let%bind get_code = Compiler_environment.get w_env.pre_environment name in
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]
@ -407,7 +413,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
return @@ seq [
expr' ;
get_code ;
modify_code ;
i_swap ; modify_code ;
set_code ;
]

4
src/ligo/compiler/compiler_type.ml
View File

@ -71,7 +71,7 @@ module Ty = struct
let%bind (Ex_ty capture) = environment_representation c in
let%bind (Ex_ty arg) = type_ arg in
let%bind (Ex_ty ret) = type_ ret in
ok @@ Ex_ty Contract_types.(pair capture @@ lambda (pair arg capture) ret)
ok @@ Ex_ty Contract_types.(pair (lambda (pair arg capture) ret) capture)
| T_map (k, v) ->
let%bind (Ex_comparable_ty k') = comparable_type k in
let%bind (Ex_ty v') = type_ v in
@ -146,7 +146,7 @@ let rec type_ : type_value -> O.michelson result =
let%bind capture = environment_closure c in
let%bind arg = type_ arg in
let%bind ret = type_ ret in
ok @@ O.t_pair capture (O.t_lambda (O.t_pair arg capture) ret)
ok @@ O.t_pair (O.t_lambda (O.t_pair arg capture) ret) capture
and environment_element (name, tyv) =
let%bind michelson_type = type_ tyv in

20
src/ligo/contracts/tuple.ligo
View File

@ -1,3 +1,13 @@
type abc is (int * int * int)
function projection_abc (const tpl : abc) : int is
block { skip } with tpl.1
function modify_abc (const tpl : abc) : abc is
block {
tpl.1 := 2048 ;
} with tpl
type foobar is (int * int)
const fb : foobar = (0, 0)
@ -10,13 +20,3 @@ function projection (const tpl : foobar) : int is
type big_tuple is (int * int * int * int * int)
const br : big_tuple = (23, 23, 23, 23, 23)
type abc is (int * int * int)
function projection_abc (const tpl : abc) : int is
block { skip } with tpl.1
function modify_abc (const tpl : abc) : abc is
block {
tpl.1 := 2048 ;
} with tpl

3
src/ligo/mini_c/combinators.ml
View File

@ -23,6 +23,9 @@ module Expression = struct
environment = env ;
is_toplevel = itl ;
}
let pair : t -> t -> t' = fun a b -> E_constant ("PAIR" , [ a ; b ])
end
let get_bool (v:value) = match v with

16
src/ligo/mini_c/environment.ml
View File

@ -30,6 +30,22 @@ module Environment (* : ENVIRONMENT *) = struct
let of_list : element list -> t = fun x -> x
let to_list : t -> element list = fun x -> x
let get_names : t -> string list = List.map fst
let remove : int -> t -> t = List.remove
let select : string list -> t -> t = fun lst env ->
let e_lst =
let e_lst = to_list env in
let aux selector (s , _) =
match List.mem s selector with
| true -> List.remove_element s selector , true
| false -> selector , false in
let e_lst' = List.fold_map_right aux lst e_lst in
let e_lst'' = List.combine e_lst e_lst' in
e_lst'' in
of_list
@@ List.map fst
@@ List.filter snd
@@ e_lst
let fold : _ -> 'a -> t -> 'a = List.fold_left

23
src/ligo/test/integration_tests.ml
View File

@ -38,6 +38,7 @@ let variant_matching () : unit result =
let%bind () =
let make_input = fun n -> e_a_constructor "Foo" (e_a_int n) in
let make_expected = e_a_int in
expect program "fb" (make_input 0) (make_expected 0) >>? fun () ->
expect_n program "fb" make_input make_expected >>? fun () ->
expect program "fb" (e_a_constructor "Kee" (e_a_nat 50)) (e_a_int 23) >>? fun () ->
expect program "fb" (e_a_constructor "Bar" (e_a_bool true)) (e_a_int 42) >>? fun () ->
@ -69,13 +70,17 @@ let higher_order () : unit result =
let shared_function () : unit result =
let%bind program = type_file "./contracts/function-shared.ligo" in
(* let%bind () =
* let make_expect = fun n -> (n + 1) in
* expect_n_int program "inc" make_expect
* in
* let%bind () =
* let make_expect = fun n -> (n + 2) in
* expect_n_int program "double_inc" make_expect
* in *)
let%bind () =
let make_expect = fun n -> (n + 1) in
expect_n_int program "inc" make_expect
in
let%bind () =
let make_expect = fun n -> (n + 2) in
expect_n_int program "double_inc" make_expect
let make_expect = fun n -> (2 * n + 3) in
expect program "foo" (e_a_int 0) (e_a_int @@ make_expect 0)
in
let%bind () =
let make_expect = fun n -> (2 * n + 3) in
@ -409,8 +414,7 @@ let main = "Integration (End to End)", [
test "variant matching" variant_matching ;
test "tuple" tuple ;
test "record" record ;
test "closure" closure ;
test "shared function" shared_function ;
test "condition" condition ;
test "shadow" shadow ;
test "multiple parameters" multiple_parameters ;
test "bool" bool_expression ;
@ -419,7 +423,6 @@ let main = "Integration (End to End)", [
test "option" option ;
test "map" map ;
test "list" list ;
test "condition" condition ;
test "loop" loop ;
test "matching" matching ;
test "declarations" declarations ;
@ -428,6 +431,8 @@ let main = "Integration (End to End)", [
test "#include directives" include_ ;
test "counter contract" counter_contract ;
test "super counter contract" super_counter_contract ;
test "closure" closure ;
test "shared function" shared_function ;
test "higher order" higher_order ;
test "basic mligo" basic_mligo ;
test "counter contract mligo" counter_mligo ;

70
src/ligo/transpiler/transpiler.ml
View File

@ -165,12 +165,11 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
let env' = env in
let return s =
ok [ (s, environment_wrap env env) ] in
let restrict : block -> block = fun b -> Combinators.append_statement' b (S_environment_select env) 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', restrict true_branch, restrict false_branch)
return @@ S_cond (expr', true_branch, false_branch)
)
| Match_option {match_none ; match_some = ((name, t), sm)} -> (
let%bind none_branch = translate_block env' match_none in
@ -179,7 +178,7 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
let env'' = Environment.add (name, t') env' in
translate_block env'' sm
in
return @@ S_if_none (expr', restrict none_branch, ((name, t'), restrict some_branch))
return @@ S_if_none (expr', none_branch, ((name, t'), some_branch))
)
| _ -> simple_fail "todo : match"
)
@ -380,11 +379,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
in aux tree'
in
let rec aux (acc , env) t =
let top =
match acc with
| None -> expr'
| Some x -> x in
let rec aux (top , env) t =
match t with
| ((`Leaf constructor_name) , tv) -> (
let%bind ((_ , name) , body) =
@ -399,19 +394,19 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
let%bind a_ty = get_t_left tv in
let a_var = "left" , a_ty in
let env' = Environment.(add a_var env) in
let%bind e = aux ((Some (Expression.make (E_variable "left") a_ty env')) , env') a in
let%bind e = aux (((Expression.make (E_variable "left") a_ty env')) , env') a in
ok (a_var , e)
in
let%bind b' =
let%bind b_ty = get_t_right tv in
let b_var = "right" , b_ty in
let env' = Environment.(add b_var env) in
let%bind e = aux ((Some (Expression.make (E_variable "right") b_ty env')) , env') b in
let%bind e = aux (((Expression.make (E_variable "right") b_ty env')) , env') b in
ok (b_var , e)
in
return ~env @@ E_if_left (top , a' , b')
in
aux (None , env) tree''
aux (expr' , env) tree''
)
| AST.Match_list _ | AST.Match_tuple (_, _) ->
simple_fail "only match bool and option exprs are translated yet"
@ -419,32 +414,35 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l ->
let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in
(* Deep capture. Capture the relevant part of the environment. Extend it with a new scope. Append it the input. *)
let%bind input_type' = translate_type input_type in
let%bind small_env =
let env' = env in
let new_env = Environment.add (binder, input_type') env' in
let free_variables = Ast_typed.Misc.Free_variables.lambda [] l in
let%bind elements =
let aux x =
let not_found_error =
let title () = "translate deep shallow (type checker didn't do its job)" in
let content () = Format.asprintf "%s in %a" x Mini_c.PP.environment new_env in
error title content in
trace_option not_found_error @@
Environment.get_opt x new_env in
bind_map_list aux free_variables in
let kvs = List.combine free_variables elements in
let small_env = Environment.of_list kvs in
ok small_env
(* Deep capture. Capture the relevant part of the environment. *)
let%bind (fv , c_env , c_tv) =
let free_variables = Ast_typed.Free_variables.lambda [] l in
let sub_env = Mini_c.Environment.select free_variables env in
let tv = Environment.closure_representation sub_env in
ok (free_variables , sub_env , tv) in
let%bind (f_expr , input_tv , output_tv) =
let%bind raw_input = translate_type input_type in
let init_env = Environment.(add (binder , raw_input) c_env) in
let input = Environment.closure_representation init_env in
let%bind output = translate_type output_type in
let%bind (statements , body_env) = translate_block init_env body in
let body =
let load_env = Environment.(add ("closure_arg" , input) empty) in
let load_expr = Expression.make_tpl (E_variable "closure_arg" , input , load_env) in
let load_st = Mini_c.statement (S_environment_load (load_expr , init_env)) load_env in
let statements' = load_st :: statements in
(statements' , body_env)
in
let new_env = Environment.(add (binder , input_type') small_env) in
let%bind (_, e) as body = translate_block new_env body in
let%bind result = translate_annotated_expression e.post_environment result in
let%bind output_type' = translate_type output_type in
let tv = Combinators.t_deep_closure small_env input_type' output_type' in
let content = D_function {binder;input=input_type';output=output_type';body;result} in
ok @@ Combinators.Expression.make_tpl (E_literal content, tv, env)
let%bind result = translate_annotated_expression body_env.post_environment result in
let tv = Mini_c.t_function input output in
let f_literal = D_function { binder ; input ; output ; body ; result } in
let expr = Expression.make_tpl (E_literal f_literal , tv , env) in
ok (expr , raw_input , output) in
let%bind c_expr =
ok @@ Expression.make_tpl (E_capture_environment fv , c_tv , env) in
let expr = Expression.pair f_expr c_expr in
let tv = Mini_c.t_deep_closure c_env input_tv output_tv in
ok @@ Expression.make_tpl (expr , tv , env)
and translate_lambda env l =
let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in