diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index f5d808df5..20ec11cb9 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -86,10 +86,14 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in let error_message () = Format.asprintf "%a" PP.expression expr in - let return ?env' code = - let env' = - let default = env in - Environment.add ("_tmp_expression" , ty) @@ Option.unopt ~default env' in + 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 prepend_env , None -> + ok @@ Environment.add ("_tmp_expression" , ty) prepend_env + | 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 @@ -120,6 +124,18 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | E_environment_capture c -> let%bind code = Compiler_environment.pack_select env c in return @@ code + | E_environment_load (expr , load_env) -> + let%bind (expr' , _) = translate_expression expr env in + let%bind clear = Compiler_environment.select env [] in + let%bind unpack = Compiler_environment.unpack load_env in + 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 ~end_env:sub_env code | E_literal v -> let%bind v = translate_value v in let%bind t = Compiler_type.type_ ty in @@ -178,7 +194,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | E_sequence (a , b) -> let%bind (a' , env_a) = translate_expression a env in let%bind (b' , env_b) = translate_expression b env_a in - return ~env':env_b @@ seq [ + return ~prepend_env:env_b @@ seq [ a' ; b' ; ] @@ -292,6 +308,36 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m ]) in return code ) + | E_assignment (name , lrs , expr) -> ( + let%bind (expr' , env') = translate_expression expr env 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 env 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 ~end_env:env @@ seq [ + expr' ; + get_code ; + i_swap ; modify_code ; + set_code ; + ] + ) and translate_statement ((s', w_env) as s:statement) : michelson result = let error_message () = Format.asprintf "%a" PP.statement s in diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index f3506d97d..01c058891 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -62,6 +62,8 @@ and value_assoc ppf : (value * value) -> unit = fun (a, b) -> 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_variable v -> fprintf ppf "%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 @@ -76,6 +78,8 @@ and expression' ppf (e:expression') = match e with | 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) -> + fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) path expression e and expression : _ -> expression -> _ = fun ppf e -> expression' ppf e.content diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index fd1b820ce..dfe4066ab 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -54,6 +54,8 @@ and selector = var_name list and expression' = | E_literal of value | E_environment_capture of selector + | E_environment_select of environment + | E_environment_load of (expression * environment) | E_constant of string * expression list | E_application of expression * expression | E_variable of var_name @@ -65,6 +67,7 @@ and 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) and expression = { content : expression' ; @@ -98,10 +101,6 @@ and anon_function = { result : expression ; } -and capture = - | No_capture (* For functions that don't capture their environments. Quotes. *) - | Deep_capture of environment (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *) - and block' = statement list and block = block' * environment_wrap