diff --git a/src/compiler/compiler_environment.ml b/src/compiler/compiler_environment.ml index 05c749095..458ac0438 100644 --- a/src/compiler/compiler_environment.ml +++ b/src/compiler/compiler_environment.ml @@ -87,7 +87,7 @@ let add : environment -> (string * type_value) -> michelson result = fun e (_s , ok code -let select : environment -> string list -> michelson result = fun e lst -> +let select ?(rev = false) : 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 @@ -96,7 +96,11 @@ let select : environment -> string list -> michelson result = fun e lst -> 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' = + if rev + then List.fold_map aux lst e_lst + else List.fold_map_right aux lst e_lst + in let e_lst'' = List.combine e_lst e_lst' in e_lst'' in let code = @@ -145,7 +149,7 @@ let clear : environment -> (michelson * environment) result = fun e -> trace_option (simple_error "try to clear empty env") @@ List.nth_opt lst 0 in let%bind code = select e [ first_name ] in - let e' = Environment.select [ first_name ] e in + let e' = Environment.select ~rev:true [ first_name ] e in ok (code , e') let pack : environment -> michelson result = fun e -> diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index ebd20a00a..e5487e3f7 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -106,11 +106,14 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m let return ?prepend_env ?end_env code = let%bind env' = match (prepend_env , end_env) with - | (Some _ , Some _) -> simple_fail ("two args to return at " ^ __LOC__) - | None , None -> ok @@ Environment.add ("_tmp_expression" , ty) env + | (Some _ , Some _) -> + simple_fail ("two args to return at " ^ __LOC__) + | None , None -> + ok @@ Environment.add ("_tmp_expression" , ty) env | Some prepend_env , None -> ok @@ Environment.add ("_tmp_expression" , ty) prepend_env - | None , Some end_env -> ok end_env in + | None , Some end_env -> + ok end_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 (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in @@ -152,6 +155,11 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m unpack ; i_skip ; ] + (* return ~end_env:load_env @@ seq [ + * expr' ; + * dip clear ; + * unpack ; + * ] *) | E_environment_select sub_env -> let%bind code = Compiler_environment.select_env env sub_env in return ~prepend_env:sub_env @@ seq [ @@ -161,6 +169,8 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | E_environment_return expr -> ( let%bind (expr' , env) = translate_expression expr env in let%bind (code , cleared_env) = Compiler_environment.clear env in + Format.printf "pre env %a\n" PP.environment env ; + Format.printf "post clean env %a\n" PP.environment cleared_env ; return ~end_env:cleared_env @@ seq [ expr' ; code ; @@ -221,7 +231,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | E_variable x -> let%bind code = Compiler_environment.get env x in return code - | E_sequence (a , b) -> + | E_sequence (a , b) -> ( let%bind (a' , env_a) = translate_expression a env in let%bind env_a' = Compiler_environment.pop env_a in let%bind (b' , env_b) = translate_expression b env_a' in @@ -230,6 +240,13 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m i_drop ; b' ; ] + (* let%bind (a' , env_a) = translate_expression a env in + * let%bind (b' , env_b) = translate_expression b env_a in + * return ~end_env:env_b @@ seq [ + * a' ; + * b' ; + * ] *) + ) | E_constant(str, lst) -> let module L = Logger.Stateful() in let%bind lst' = @@ -313,9 +330,9 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | E_if_left (c, (l_ntv , l), (r_ntv , r)) -> ( let%bind (c' , _env') = translate_expression c env in let l_env = Environment.add l_ntv env in - let%bind (l' , _) = translate_expression l l_env in + let%bind (l' , _l_env') = translate_expression l l_env in let r_env = Environment.add r_ntv env in - let%bind (r' , _) = translate_expression r r_env in + let%bind (r' , _r_env') = translate_expression r r_env in let%bind restrict_l = Compiler_environment.select_env l_env env in let%bind restrict_r = Compiler_environment.select_env r_env env in let%bind code = ok (seq [ @@ -406,7 +423,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m 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 + let%bind (expr , env') = translate_expression result env in let code = seq [ i_comment "function result" ; expr ; @@ -419,10 +436,13 @@ and translate_quote_body ({result ; binder ; input} as f:anon_function) : michel let output_stack_ty = Stack.(output_ty @: nil) in let error_message () = Format.asprintf - "\ncode : %a\ninput : %a\noutput : %a\n" + "\nCode : %a\nMichelson code : %a\ninput : %a\noutput : %a\nstart env : %a\nend env : %a\n" + PP.expression result Michelson.pp code PP.type_ f.input PP.type_ f.output + PP.environment env + PP.environment env' in let%bind _ = Trace.trace_tzresult_lwt ( diff --git a/src/compiler/compiler_type.ml b/src/compiler/compiler_type.ml index 2632f2bd8..5977db461 100644 --- a/src/compiler/compiler_type.ml +++ b/src/compiler/compiler_type.ml @@ -10,12 +10,14 @@ module Contract_types = Meta_michelson.Types module Ty = struct let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) () + let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) () let comparable_type_base : type_base -> ex_comparable_ty result = fun tb -> let open Contract_types in let return x = ok @@ Ex_comparable_ty x in match tb with | Base_unit -> fail (not_comparable "unit") + | Base_void -> fail (not_comparable "void") | Base_bool -> fail (not_comparable "bool") | Base_nat -> return nat_k | Base_tez -> return tez_k @@ -44,6 +46,7 @@ module Ty = struct let return x = ok @@ Ex_ty x in match b with | Base_unit -> return unit + | Base_void -> fail (not_compilable_type "void") | Base_bool -> return bool | Base_int -> return int | Base_nat -> return nat @@ -118,6 +121,7 @@ end let base_type : type_base -> O.michelson result = function | Base_unit -> ok @@ O.prim T_unit + | Base_void -> fail (Ty.not_compilable_type "void") | Base_bool -> ok @@ O.prim T_bool | Base_int -> ok @@ O.prim T_int | Base_nat -> ok @@ O.prim T_nat diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index af5543689..bf848723b 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -10,6 +10,7 @@ let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R let type_base ppf : type_base -> _ = function | Base_unit -> fprintf ppf "unit" + | Base_void -> fprintf ppf "void" | Base_bool -> fprintf ppf "bool" | Base_int -> fprintf ppf "int" | Base_nat -> fprintf ppf "nat" @@ -48,7 +49,7 @@ let rec value ppf : value -> unit = function | D_nat n -> fprintf ppf "+%d" n | D_timestamp n -> fprintf ppf "+%d" n | D_tez n -> fprintf ppf "%dtz" n - | D_unit -> fprintf ppf " " + | D_unit -> fprintf ppf "unit" | D_string s -> fprintf ppf "\"%s\"" s | D_bytes _ -> fprintf ppf "[bytes]" | D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b @@ -68,12 +69,12 @@ and expression' ppf (e:expression') = match e with | E_environment_capture s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s | E_environment_load (expr , env) -> fprintf ppf "load %a in %a" expression expr environment env | E_environment_select env -> fprintf ppf "select %a" environment env - | E_environment_return expr -> fprintf ppf "return %a" expression expr + | E_environment_return expr -> fprintf ppf "return (%a)" expression expr | E_skip -> fprintf ppf "skip" - | E_variable v -> fprintf ppf "%s" v + | E_variable v -> fprintf ppf "V(%s)" v | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b | E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst - | E_literal v -> fprintf ppf "%a" value v + | E_literal v -> fprintf ppf "L(%a)" value v | E_make_empty_map _ -> fprintf ppf "map[]" | E_make_empty_list _ -> fprintf ppf "list[]" | E_make_empty_set _ -> fprintf ppf "set[]" @@ -82,8 +83,7 @@ and expression' ppf (e:expression') = match e with | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r - | E_sequence (a , b) -> fprintf ppf "%a ; %a" expression a expression b - (* | E_sequence_drop (a , b) -> fprintf ppf "%a ;- %a" expression a expression b *) + | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b | E_let_in ((name , _) , expr , body) -> fprintf ppf "let %s = %a in ( %a )" name expression expr expression body | E_assignment (r , path , e) -> diff --git a/src/mini_c/environment.ml b/src/mini_c/environment.ml index 8c1bc796c..36f62a15e 100644 --- a/src/mini_c/environment.ml +++ b/src/mini_c/environment.ml @@ -32,14 +32,18 @@ module Environment (* : ENVIRONMENT *) = struct 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 select ?(rev = false) : 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' = + if rev + then List.fold_map aux lst e_lst + else List.fold_map_right aux lst e_lst + in let e_lst'' = List.combine e_lst e_lst' in e_lst'' in of_list diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 57f117165..77fa0a026 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -1,7 +1,7 @@ type type_name = string type type_base = - | Base_unit + | Base_unit | Base_void | Base_bool | Base_int | Base_nat | Base_tez | Base_timestamp diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 8dbaf60a8..88e7b5ad9 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -539,7 +539,7 @@ and translate_lambda env l = let%bind output = translate_type output_type in let tv = Combinators.t_function input output in let content = D_function {binder;input;output;result=result'} in - ok @@ Combinators.Expression.make_tpl (E_literal content, tv) + ok @@ Combinators.Expression.make_tpl (E_literal content , tv) ) | _ -> ( translate_lambda_deep env l