From 2840eb74144222b85a2bc9649af1101a669ba52f Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 27 Sep 2019 17:31:38 +0200 Subject: [PATCH 1/7] Treat env element expression as deep_closure only if they are lambda --- src/passes/6-transpiler/transpiler.ml | 15 ++++++++++----- src/test/contracts/high-order.ligo | 12 +++++++++++- src/test/integration_tests.ml | 11 +++++++++-- 3 files changed, 30 insertions(+), 8 deletions(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index db7fe394a..4d0cec3f0 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -225,11 +225,16 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele -> match (AST.get_type' ele.type_value , ele.definition) with | (AST.T_function (f , arg) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) -> - let%bind f' = transpile_type f in - let%bind arg' = transpile_type arg in - let%bind env' = transpile_environment ae.environment in - let sub_env = Mini_c.Environment.select captured_variables env' in - ok @@ Combinators.t_deep_closure sub_env f' arg' + begin + match ae.expression with + | E_lambda _ -> + let%bind f' = transpile_type f in + let%bind arg' = transpile_type arg in + let%bind env' = transpile_environment ae.environment in + let sub_env = Mini_c.Environment.select captured_variables env' in + ok @@ Combinators.t_deep_closure sub_env f' arg' + | _ -> transpile_type ele.type_value + end | _ -> transpile_type ele.type_value and transpile_small_environment : AST.small_environment -> Environment.t result = fun x -> diff --git a/src/test/contracts/high-order.ligo b/src/test/contracts/high-order.ligo index 7c897d4ee..8ab9fdfec 100644 --- a/src/test/contracts/high-order.ligo +++ b/src/test/contracts/high-order.ligo @@ -1,8 +1,18 @@ // Test a PascaLIGO function which takes another PascaLIGO function as an argument - function foobar (const i : int) : int is function foo (const i : int) : int is block { skip } with i ; function bar (const f : int -> int) : int is block { skip } with f ( i ) ; block { skip } with bar (foo) ; + +// higher order function with more than one argument +function higher2(const i: int; const f: int -> int): int is + block { + const ii: int = f(i) + } with ii + +function foobar2 (const i : int) : int is + function foo2 (const i : int) : int is + block { skip } with i; + block { skip } with higher2(i,foo2) \ No newline at end of file diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index fbc966747..e48a10e9a 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -110,8 +110,15 @@ let shadow () : unit result = let higher_order () : unit result = let%bind program = type_file "./contracts/high-order.ligo" in - let make_expect = fun n -> n in - expect_eq_n_int program "foobar" make_expect + let%bind _ = + let make_expect = fun n -> n in + expect_eq_n_int program "foobar" make_expect + in + let%bind _ = + let make_expect = fun n -> n in + expect_eq_n_int program "foobar2" make_expect + in + ok () let shared_function () : unit result = let%bind program = type_file "./contracts/function-shared.ligo" in From ae882c39ef67dd6524c9074d6908127f0a150a32 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 30 Sep 2019 16:34:20 +0200 Subject: [PATCH 2/7] Variable name gardening --- src/passes/6-transpiler/transpiler.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 4d0cec3f0..346791a30 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -224,15 +224,15 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele -> match (AST.get_type' ele.type_value , ele.definition) with - | (AST.T_function (f , arg) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) -> + | (AST.T_function (arg , ret) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) -> begin match ae.expression with | E_lambda _ -> - let%bind f' = transpile_type f in + let%bind ret' = transpile_type ret in let%bind arg' = transpile_type arg in let%bind env' = transpile_environment ae.environment in let sub_env = Mini_c.Environment.select captured_variables env' in - ok @@ Combinators.t_deep_closure sub_env f' arg' + ok @@ Combinators.t_deep_closure sub_env arg' ret' | _ -> transpile_type ele.type_value end | _ -> transpile_type ele.type_value From a7565145d5c1d448fe70eb172b20fd102381a67c Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 2 Oct 2019 17:20:48 +0200 Subject: [PATCH 3/7] add map_expression function in self_mini_c pass helpers --- src/passes/6-transpiler/dune | 1 + src/passes/7-self_mini_c/dune | 11 ++++ src/passes/7-self_mini_c/helpers.ml | 73 ++++++++++++++++++++++++ src/stages/mini_c/types.ml | 6 +- vendors/ligo-utils/simple-utils/trace.ml | 7 +++ 5 files changed, 95 insertions(+), 3 deletions(-) create mode 100644 src/passes/7-self_mini_c/dune create mode 100644 src/passes/7-self_mini_c/helpers.ml diff --git a/src/passes/6-transpiler/dune b/src/passes/6-transpiler/dune index 3f483bda3..a547714f0 100644 --- a/src/passes/6-transpiler/dune +++ b/src/passes/6-transpiler/dune @@ -6,6 +6,7 @@ tezos-utils ast_typed mini_c + self_mini_c operators ) (preprocess diff --git a/src/passes/7-self_mini_c/dune b/src/passes/7-self_mini_c/dune new file mode 100644 index 000000000..ec9f97639 --- /dev/null +++ b/src/passes/7-self_mini_c/dune @@ -0,0 +1,11 @@ +(library + (name self_mini_c) + (public_name ligo.self_mini_c) + (libraries + mini_c + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/7-self_mini_c/helpers.ml b/src/passes/7-self_mini_c/helpers.ml new file mode 100644 index 000000000..f0d11ff80 --- /dev/null +++ b/src/passes/7-self_mini_c/helpers.ml @@ -0,0 +1,73 @@ +open Mini_c +open Trace + +type mapper = expression -> expression result +(* fold ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a *) + +let rec map_expression : mapper -> expression -> expression result = fun f e -> + let self = map_expression f in + let%bind e' = f e in + let return content = ok { e' with content } in + match e'.content with + | E_variable _ | E_skip | E_make_none _ + | E_make_empty_map (_,_) | E_make_empty_list _ | E_make_empty_set _ as em -> return em + | E_literal v -> ( + let%bind v' = match v with + | D_function an -> + let%bind body = self an.body in + ok @@ D_function { an with body } + | _ -> ok v in + return @@ E_literal v' + ) + | E_constant (name, lst) -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_constant (name,lst') + ) + | E_closure af -> ( + let%bind body = self af.body in + return @@ E_closure { af with body } + ) + | E_application farg -> ( + let%bind farg' = bind_map_pair self farg in + return @@ E_application farg' + ) + | E_iterator (s, ((name , tv) , body) , exp) -> ( + let%bind (exp',body') = bind_map_pair self (exp,body) in + return @@ E_iterator (s, ((name , tv) , body') , exp') + ) + | E_fold (((name , tv) , body) , col , init) -> ( + let%bind (body',col',init') = bind_map_triple self (body,col,init) in + return @@ E_fold (((name , tv) , body') , col', init') + ) + | E_while eb -> ( + let%bind eb' = bind_map_pair self eb in + return @@ E_while eb' + ) + | E_if_bool cab -> ( + let%bind cab' = bind_map_triple self cab in + return @@ E_if_bool cab' + ) + | E_if_none (c, n, ((name, tv) , s)) -> ( + let%bind (c',n',s') = bind_map_triple self (c,n,s) in + return @@ E_if_none (c', n', ((name, tv) , s')) + ) + | E_if_cons (c, n, (((hd, hdtv) , (tl, tltv)) , cons)) -> ( + let%bind (c',n',cons') = bind_map_triple self (c,n,cons) in + return @@ E_if_cons (c', n', (((hd, hdtv) , (tl, tltv)) , cons')) + ) + | E_if_left (c, ((name_l, tvl) , l), ((name_r, tvr) , r)) -> ( + let%bind (c',l',r') = bind_map_triple self (c,l,r) in + return @@ E_if_left (c', ((name_l, tvl) , l'), ((name_r, tvr) , r')) + ) + | E_let_in ((v , tv) , expr , body) -> ( + let%bind (expr',body') = bind_map_pair self (expr,body) in + return @@ E_let_in ((v , tv) , expr' , body') + ) + | E_sequence ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_sequence ab' + ) + | E_assignment (s, lrl, exp) -> ( + let%bind exp' = self exp in + return @@ E_assignment (s, lrl, exp') + ) \ No newline at end of file diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index 7b7f1093d..5901b7dc6 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -64,7 +64,7 @@ and expression' = | E_closure of anon_function | E_skip | E_constant of string * expression list - | E_application of expression * expression + | E_application of (expression * expression) | E_variable of var_name | E_make_empty_map of (type_value * type_value) | E_make_empty_list of type_value @@ -72,14 +72,14 @@ and expression' = | E_make_none of type_value | E_iterator of (string * ((var_name * type_value) * expression) * expression) | E_fold of (((var_name * type_value) * expression) * expression * expression) - | E_if_bool of expression * expression * expression + | E_if_bool of (expression * expression * expression) | E_if_none of expression * expression * ((var_name * type_value) * expression) | E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression)) | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) | E_let_in of ((var_name * type_value) * expression * expression) | E_sequence of (expression * expression) | E_assignment of (string * [`Left | `Right] list * expression) - | E_while of expression * expression + | E_while of (expression * expression) and expression = { content : expression' ; diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 329203a46..482ed6e86 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -661,10 +661,17 @@ let bind_and (a, b) = a >>? fun a -> b >>? fun b -> ok (a, b) +let bind_and3 (a, b, c) = + a >>? fun a -> + b >>? fun b -> + c >>? fun c -> + ok (a, b, c) let bind_pair = bind_and let bind_map_pair f (a, b) = bind_pair (f a, f b) +let bind_map_triple f (a, b, c) = + bind_and3 (f a, f b, f c) (** From 6fbe43d28af324e508dafa9124a52f516d38954c Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 2 Oct 2019 17:28:11 +0200 Subject: [PATCH 4/7] Check for closure when applying a function and update tests --- src/passes/6-transpiler/transpiler.ml | 8 +++++++- src/test/contracts/high-order.ligo | 9 ++++++++- src/test/integration_tests.ml | 15 ++++++--------- 3 files changed, 21 insertions(+), 11 deletions(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 346791a30..470eb726e 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -280,7 +280,13 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re | E_application (a, b) -> let%bind a = transpile_annotated_expression a in let%bind b = transpile_annotated_expression b in - return @@ E_application (a, b) + let%bind b' = Self_mini_c.Helpers.map_expression + (fun exp -> + match exp.type_value with + | T_deep_closure _ -> fail @@ simple_error "Cannot apply closure in function argument" + | _ -> ok exp + ) b in + return @@ E_application (a, b') | E_constructor (m, param) -> ( let%bind param' = transpile_annotated_expression param in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in diff --git a/src/test/contracts/high-order.ligo b/src/test/contracts/high-order.ligo index 8ab9fdfec..9408fd36a 100644 --- a/src/test/contracts/high-order.ligo +++ b/src/test/contracts/high-order.ligo @@ -15,4 +15,11 @@ function higher2(const i: int; const f: int -> int): int is function foobar2 (const i : int) : int is function foo2 (const i : int) : int is block { skip } with i; - block { skip } with higher2(i,foo2) \ No newline at end of file + block { skip } with higher2(i,foo2) + +// This is not supported yet: +// const a : int = 123; +// function foobar3 (const i : int) : int is +// function foo2 (const i : int) : int is +// block { skip } with (a+i); +// block { skip } with higher2(i,foo2) \ No newline at end of file diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index e48a10e9a..f5b4a7aad 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -110,15 +110,12 @@ let shadow () : unit result = let higher_order () : unit result = let%bind program = type_file "./contracts/high-order.ligo" in - let%bind _ = - let make_expect = fun n -> n in - expect_eq_n_int program "foobar" make_expect - in - let%bind _ = - let make_expect = fun n -> n in - expect_eq_n_int program "foobar2" make_expect - in - ok () + let make_expect = fun n -> n in + let%bind _ = expect_eq_n_int program "foobar" make_expect in + let%bind _ = expect_eq_n_int program "foobar2" make_expect in + (* not supported yet: + let%bind _ = expect_eq_n_int program "foobar3" make_expect in *) + ok () let shared_function () : unit result = let%bind program = type_file "./contracts/function-shared.ligo" in From 962a98da7523403fe9fdd5d7da7c896859db81ef Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 3 Oct 2019 10:21:09 +0200 Subject: [PATCH 5/7] emmit a t_function when no variables are captured --- src/passes/6-transpiler/transpiler.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 470eb726e..b8017f6b8 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -232,7 +232,10 @@ and transpile_environment_element_type : AST.environment_element -> type_value r let%bind arg' = transpile_type arg in let%bind env' = transpile_environment ae.environment in let sub_env = Mini_c.Environment.select captured_variables env' in - ok @@ Combinators.t_deep_closure sub_env arg' ret' + if sub_env = [] then + transpile_type ele.type_value + else + ok @@ Combinators.t_deep_closure sub_env arg' ret' | _ -> transpile_type ele.type_value end | _ -> transpile_type ele.type_value From 4e333836cbcf1854b5356a98fc0221bb8794844c Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 3 Oct 2019 15:36:06 +0200 Subject: [PATCH 6/7] ignore closure error in subexpression of argument --- src/passes/6-transpiler/transpiler.ml | 19 ++++--- src/passes/7-self_mini_c/helpers.ml | 69 +++++++++++++++++++++++- src/test/contracts/high-order.ligo | 14 ++++- src/test/integration_tests.ml | 1 + vendors/ligo-utils/simple-utils/trace.ml | 14 +++++ 5 files changed, 108 insertions(+), 9 deletions(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index b8017f6b8..9427ed5bd 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -283,13 +283,18 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re | E_application (a, b) -> let%bind a = transpile_annotated_expression a in let%bind b = transpile_annotated_expression b in - let%bind b' = Self_mini_c.Helpers.map_expression - (fun exp -> - match exp.type_value with - | T_deep_closure _ -> fail @@ simple_error "Cannot apply closure in function argument" - | _ -> ok exp - ) b in - return @@ E_application (a, b') + let%bind _err = Self_mini_c.Helpers.fold_expression + (fun sub_arg exp -> + match (exp.type_value , exp.content) with + | T_pair _ , _ -> ok false + | T_base _ , E_application _ -> ok true + | (T_deep_closure _), _ -> + let errmsg = Format.asprintf "Cannot apply closure in function arguments: %a\n" + Mini_c.PP.expression_with_type b in + if sub_arg then ok sub_arg else fail @@ simple_error errmsg + | _,_ -> ok sub_arg + ) false b in + return @@ E_application (a, b) | E_constructor (m, param) -> ( let%bind param' = transpile_annotated_expression param in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in diff --git a/src/passes/7-self_mini_c/helpers.ml b/src/passes/7-self_mini_c/helpers.ml index f0d11ff80..c7553f908 100644 --- a/src/passes/7-self_mini_c/helpers.ml +++ b/src/passes/7-self_mini_c/helpers.ml @@ -1,8 +1,75 @@ open Mini_c open Trace +type 'a folder = 'a -> expression -> 'a result +let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> + let self = fold_expression f in + let%bind init' = f init e in + match e.content with + | E_variable _ | E_skip | E_make_none _ + | E_make_empty_map (_,_) | E_make_empty_list _ + | E_make_empty_set _ -> ( + ok init' + ) + | E_literal v -> ( + match v with + | D_function an -> self init' an.body + | _ -> ok init' + ) + | E_constant (_, lst) -> ( + let%bind res = bind_fold_list self init' lst in + ok res + ) + | E_closure af -> ( + let%bind res = self init' af.body in + ok res + ) + | E_application farg -> ( + let%bind res = bind_fold_pair self init' farg in + ok res + ) + | E_iterator (_, ((_ , _) , body) , exp) -> ( + let%bind res = bind_fold_pair self init' (exp,body) in + ok res + ) + | E_fold (((_ , _) , body) , col , init) -> ( + let%bind res = bind_fold_triple self init' (body,col,init) in + ok res + ) + | E_while eb -> ( + let%bind res = bind_fold_pair self init' eb in + ok res + ) + | E_if_bool cab -> ( + let%bind res = bind_fold_triple self init' cab in + ok res + ) + | E_if_none (c, n, ((_, _) , s)) -> ( + let%bind res = bind_fold_triple self init' (c,n,s) in + ok res + ) + | E_if_cons (c, n, (((_, _) , (_, _)) , cons)) -> ( + let%bind res = bind_fold_triple self init' (c,n,cons) in + ok res + ) + | E_if_left (c, ((_, _) , l), ((_, _) , r)) -> ( + let%bind res = bind_fold_triple self init' (c,l,r) in + ok res + ) + | E_let_in ((_, _) , expr , body) -> ( + let%bind res = bind_fold_pair self init' (expr,body) in + ok res + ) + | E_sequence ab -> ( + let%bind res = bind_fold_pair self init' ab in + ok res + ) + | E_assignment (_, _, exp) -> ( + let%bind res = self init' exp in + ok res + ) + type mapper = expression -> expression result -(* fold ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a *) let rec map_expression : mapper -> expression -> expression result = fun f e -> let self = map_expression f in diff --git a/src/test/contracts/high-order.ligo b/src/test/contracts/high-order.ligo index 9408fd36a..d3c83170a 100644 --- a/src/test/contracts/high-order.ligo +++ b/src/test/contracts/high-order.ligo @@ -22,4 +22,16 @@ function foobar2 (const i : int) : int is // function foobar3 (const i : int) : int is // function foo2 (const i : int) : int is // block { skip } with (a+i); -// block { skip } with higher2(i,foo2) \ No newline at end of file +// block { skip } with higher2(i,foo2) + +function f (const i : int) : int is + block { skip } + with i + +function g (const i : int) : int is + block { skip } + with f(i) + +function foobar4 (const i : int) : int is + block { skip } + with g(g(i)) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index f5b4a7aad..16a4c7d69 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -115,6 +115,7 @@ let higher_order () : unit result = let%bind _ = expect_eq_n_int program "foobar2" make_expect in (* not supported yet: let%bind _ = expect_eq_n_int program "foobar3" make_expect in *) + let%bind _ = expect_eq_n_int program "foobar4" make_expect in ok () let shared_function () : unit result = diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 482ed6e86..54f69246e 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -592,6 +592,20 @@ let bind_fold_list f init lst = in List.fold_left aux (ok init) lst +let bind_fold_pair f init (a,b) = + let aux x y = + x >>? fun x -> + f x y + in + List.fold_left aux (ok init) [a;b] + +let bind_fold_triple f init (a,b,c) = + let aux x y = + x >>? fun x -> + f x y + in + List.fold_left aux (ok init) [a;b;c] + let bind_fold_map_list = fun f acc lst -> let rec aux (acc , prev) f = function | [] -> ok (acc , prev) From c1845c2bfe0dd65865fb177e2f99b12e46981c3d Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 3 Oct 2019 18:35:11 +0200 Subject: [PATCH 7/7] Only look at arg.type_value instead of arg.content --- src/passes/6-transpiler/transpiler.ml | 27 +++++++++++++++------------ src/passes/7-self_mini_c/helpers.ml | 22 +++++++++++++++++++++- 2 files changed, 36 insertions(+), 13 deletions(-) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 9427ed5bd..0cef7b26b 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -283,18 +283,21 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re | E_application (a, b) -> let%bind a = transpile_annotated_expression a in let%bind b = transpile_annotated_expression b in - let%bind _err = Self_mini_c.Helpers.fold_expression - (fun sub_arg exp -> - match (exp.type_value , exp.content) with - | T_pair _ , _ -> ok false - | T_base _ , E_application _ -> ok true - | (T_deep_closure _), _ -> - let errmsg = Format.asprintf "Cannot apply closure in function arguments: %a\n" - Mini_c.PP.expression_with_type b in - if sub_arg then ok sub_arg else fail @@ simple_error errmsg - | _,_ -> ok sub_arg - ) false b in - return @@ E_application (a, b) + let%bind contains_closure = + Self_mini_c.Helpers.fold_type_value + (fun contains_closure exp -> + ok (contains_closure + || match exp with + | T_deep_closure _ -> true + | _ -> false)) + false + b.type_value in + if contains_closure + then + let errmsg = Format.asprintf "Cannot apply closure in function arguments: %a\n" + Mini_c.PP.expression_with_type b in + fail @@ simple_error errmsg + else return @@ E_application (a, b) | E_constructor (m, param) -> ( let%bind param' = transpile_annotated_expression param in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in diff --git a/src/passes/7-self_mini_c/helpers.ml b/src/passes/7-self_mini_c/helpers.ml index c7553f908..9904a8083 100644 --- a/src/passes/7-self_mini_c/helpers.ml +++ b/src/passes/7-self_mini_c/helpers.ml @@ -1,6 +1,26 @@ open Mini_c open Trace +let rec fold_type_value : ('a -> type_value -> 'a result) -> 'a -> type_value -> 'a result = fun f init t -> + let self = fold_type_value f in + let%bind init' = f init t in + match t with + | T_pair ((_, a), (_, b)) + | T_or ((_, a), (_, b)) + | T_function (a, b) + | T_map (a, b) + | T_big_map (a, b) -> + bind_fold_pair self init' (a, b) + | T_deep_closure (env, a, b) -> + bind_fold_list self init' (List.map snd env @ [a; b]) + | T_list a + | T_set a + | T_contract a + | T_option a -> + self init' a + | T_base _ -> + ok init' + type 'a folder = 'a -> expression -> 'a result let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> let self = fold_expression f in @@ -137,4 +157,4 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> | E_assignment (s, lrl, exp) -> ( let%bind exp' = self exp in return @@ E_assignment (s, lrl, exp') - ) \ No newline at end of file + )