From 21e8298a4eae0d7cc0505e8962e307dc26112f80 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Mon, 23 Mar 2020 16:00:50 +0100 Subject: [PATCH 1/2] add assign back --- src/passes/10-interpreter/interpreter.ml | 4 +- src/passes/10-transpiler/transpiler.ml | 9 +- .../2-concrete_to_imperative/cameligo.ml | 9 +- .../2-concrete_to_imperative/pascaligo.ml | 40 ++++----- src/passes/3-self_ast_imperative/helpers.ml | 31 ++++--- .../imperative_to_sugar.ml | 88 +++++++++++++------ src/passes/5-self_ast_sugar/helpers.ml | 12 +-- src/passes/6-sugar_to_core/sugar_to_core.ml | 12 +-- src/passes/8-typer-new/typer.ml | 10 +-- src/passes/8-typer-old/typer.ml | 10 +-- src/passes/9-self_ast_typed/helpers.ml | 12 +-- src/passes/9-self_ast_typed/tail_recursion.ml | 4 +- src/stages/1-ast_imperative/PP.ml | 21 +++-- src/stages/1-ast_imperative/combinators.ml | 28 +++--- src/stages/1-ast_imperative/combinators.mli | 5 +- src/stages/1-ast_imperative/misc.ml | 1 + src/stages/1-ast_imperative/types.ml | 15 +++- src/stages/2-ast_sugar/PP.ml | 4 +- src/stages/2-ast_sugar/combinators.ml | 53 ++++------- src/stages/2-ast_sugar/combinators.mli | 57 ++++++------ src/stages/2-ast_sugar/types.ml | 2 +- src/stages/3-ast_core/PP.ml | 2 +- src/stages/3-ast_core/combinators.ml | 4 +- src/stages/3-ast_core/types.ml | 2 +- src/stages/4-ast_typed/PP.ml | 2 +- src/stages/4-ast_typed/combinators.ml | 2 +- src/stages/4-ast_typed/misc.ml | 2 +- src/stages/4-ast_typed/misc_smart.ml | 2 +- src/stages/4-ast_typed/types.ml | 2 +- src/stages/typesystem/misc.ml | 6 +- src/test/multisig_v2_tests.ml | 2 +- 31 files changed, 242 insertions(+), 211 deletions(-) diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index 1a04d35c4..43e78312a 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -316,8 +316,8 @@ and eval : Ast_typed.expression -> env -> value result ok (label,v')) (LMap.to_kv_list recmap) in ok @@ V_Record (LMap.of_list lv') - | E_record_accessor { expr ; label} -> ( - let%bind record' = eval expr env in + | E_record_accessor { record ; label} -> ( + let%bind record' = eval record env in match record' with | V_Record recmap -> let%bind a = trace_option (simple_error "unknown record field") @@ diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 2d726d2df..b83e84bf6 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -301,11 +301,12 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = trace_strong (corner_case ~loc:__LOC__ "record build") @@ Append_tree.fold_ne (transpile_annotated_expression) aux node ) - | E_record_accessor {expr; label} -> - let%bind ty' = transpile_type (get_type_expression expr) in + | E_record_accessor {record; label} -> + let ty = get_type_expression record in + let%bind ty' = transpile_type ty in let%bind ty_lmap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ - get_t_record (get_type_expression expr) in + get_t_record ty in let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in let%bind path = trace_strong (corner_case ~loc:__LOC__ "record access") @@ @@ -315,7 +316,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = | `Left -> C_CAR | `Right -> C_CDR in Combinators.Expression.make_tpl (E_constant {cons_name=c;arguments=[pred]} , ty) in - let%bind record' = transpile_annotated_expression expr in + let%bind record' = transpile_annotated_expression record in let expr = List.fold_left aux record' path in ok expr | E_record_update {record; path; update} -> diff --git a/src/passes/2-concrete_to_imperative/cameligo.ml b/src/passes/2-concrete_to_imperative/cameligo.ml index f6b2ef165..371e0c784 100644 --- a/src/passes/2-concrete_to_imperative/cameligo.ml +++ b/src/passes/2-concrete_to_imperative/cameligo.ml @@ -383,11 +383,10 @@ let rec compile_expression : match variables with | hd :: [] -> if (List.length prep_vars = 1) - then e_let_in hd false inline rhs_b_expr body - else e_let_in hd false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body + then e_let_in hd inline rhs_b_expr body + else e_let_in hd inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body | hd :: tl -> e_let_in hd - false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - (List.length tl) - 1))) (chain_let_in tl body) @@ -408,7 +407,7 @@ let rec compile_expression : let%bind ret_expr = if List.length prep_vars = 1 then ok (chain_let_in prep_vars body) (* Bind the right hand side so we only evaluate it once *) - else ok (e_let_in (rhs_b, ty_opt) false inline rhs' (chain_let_in prep_vars body)) + else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body)) in let%bind ret_expr = match kwd_rec with | None -> ok @@ ret_expr @@ -572,7 +571,7 @@ let rec compile_expression : | Raw.PVar y -> let var_name = Var.of_name y.value in let%bind type_expr = compile_type_expression x'.type_expr in - return @@ e_let_in (var_name , Some type_expr) false false e rhs + return @@ e_let_in (var_name , Some type_expr) false e rhs | _ -> default_action () ) | _ -> default_action () diff --git a/src/passes/2-concrete_to_imperative/pascaligo.ml b/src/passes/2-concrete_to_imperative/pascaligo.ml index 53287557d..2eb055351 100644 --- a/src/passes/2-concrete_to_imperative/pascaligo.ml +++ b/src/passes/2-concrete_to_imperative/pascaligo.ml @@ -14,8 +14,6 @@ let pseq_to_list = function | Some lst -> npseq_to_list lst let get_value : 'a Raw.reg -> 'a = fun x -> x.value - - module Errors = struct let unsupported_cst_constr p = let title () = "" in @@ -134,10 +132,10 @@ let r_split = Location.r_split [return_statement] is used for non-let-in statements. *) -let return_let_in ?loc binder mut inline rhs = ok @@ fun expr'_opt -> +let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt -> match expr'_opt with - | None -> ok @@ e_let_in ?loc binder mut inline rhs (e_skip ()) - | Some expr' -> ok @@ e_let_in ?loc binder mut inline rhs expr' + | None -> ok @@ e_let_in ?loc binder inline rhs (e_skip ()) + | Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr' let return_statement expr = ok @@ fun expr'_opt -> match expr'_opt with @@ -525,7 +523,7 @@ and compile_data_declaration : Raw.data_decl -> _ result = let name = x.name.value in let%bind t = compile_type_expression x.var_type in let%bind expression = compile_expression x.init in - return_let_in ~loc (Var.of_name name, Some t) false false expression + return_let_in ~loc (Var.of_name name, Some t) false expression | LocalConst x -> let (x , loc) = r_split x in let name = x.name.value in @@ -537,7 +535,7 @@ and compile_data_declaration : Raw.data_decl -> _ result = | Some {value; _} -> npseq_to_list value.ne_elements |> List.exists (fun Region.{value; _} -> value = "\"inline\"") - in return_let_in ~loc (Var.of_name name, Some t) false inline expression + in return_let_in ~loc (Var.of_name name, Some t) inline expression | LocalFun f -> let (f , loc) = r_split f in let%bind (binder, expr) = compile_fun_decl ~loc f in @@ -547,7 +545,7 @@ and compile_data_declaration : Raw.data_decl -> _ result = | Some {value; _} -> npseq_to_list value.ne_elements |> List.exists (fun Region.{value; _} -> value = "\"inline\"") - in return_let_in ~loc binder false inline expr + in return_let_in ~loc binder inline expr and compile_param : Raw.param_decl -> (string * type_expression) result = @@ -618,7 +616,7 @@ and compile_fun_decl : let expr = e_accessor (e_variable arguments_name) (string_of_int i) in let type_variable = Some type_expr in - let ass = return_let_in (Var.of_name param , type_variable) false inline expr in + let ass = return_let_in (Var.of_name param , type_variable) inline expr in ass in bind_list @@ List.mapi aux params in @@ -681,7 +679,7 @@ and compile_fun_expression : let aux = fun i (param, param_type) -> let expr = e_accessor (e_variable arguments_name) (string_of_int i) in let type_variable = Some param_type in - let ass = return_let_in (Var.of_name param , type_variable) false false expr in + let ass = return_let_in (Var.of_name param , type_variable) false expr in ass in bind_list @@ List.mapi aux params in @@ -817,8 +815,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res match a.lhs with | Path path -> ( let (name , path') = compile_path path in - let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in - return_let_in let_binder mut inline rhs + return_statement @@ e_ez_assign ~loc name path' value_expr ) | MapPath v -> ( let v' = v.value in @@ -831,8 +828,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res in let%bind key_expr = compile_expression v'.index.value.inside in let expr' = e_map_add key_expr value_expr map in - let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in - return_let_in let_binder mut inline rhs + return_statement @@ e_ez_assign ~loc varname path expr' ) ) | CaseInstr c -> ( @@ -872,9 +868,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in let%bind expr = compile_update {value=u;region=reg} in let (name , access_path) = compile_path r.path in - let loc = Some loc in - let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc name access_path expr ) | MapPatch patch -> ( @@ -897,8 +891,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in - let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc name access_path assigns ) | SetPatch patch -> ( let (setp, loc) = r_split patch in @@ -913,8 +906,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res let assigns = List.fold_right (fun hd s -> e_constant C_SET_ADD [hd ; s]) inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in - let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc name access_path assigns ) | MapRemove r -> ( let (v , loc) = r_split r in @@ -928,8 +920,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res in let%bind key' = compile_expression key in let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in - let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc varname path expr ) | SetRemove r -> ( let (set_rm, loc) = r_split r in @@ -942,8 +933,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res in let%bind removed' = compile_expression set_rm.element in let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in - let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in - return_let_in binder mut inline rhs + return_statement @@ e_ez_assign ~loc varname path expr ) and compile_path : Raw.path -> string * string list = fun p -> diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index 42ee86259..f70b21aaf 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -47,8 +47,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = fold_expression self res update in ok res ) - | E_record_accessor {expr} -> ( - let%bind res = self init' expr in + | E_record_accessor {record} -> ( + let%bind res = self init' record in ok res ) | E_let_in { let_binder = _ ; rhs ; let_result } -> ( @@ -63,6 +63,9 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let ab = (expr1,expr2) in let%bind res = bind_fold_pair self init' ab in ok res + | E_assign {variable=_;access_path=_;expression} -> + let%bind res = self init' expression in + ok res | E_for {body; _} -> let%bind res = self init' body in ok res @@ -74,6 +77,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self init' condition in let%bind res = self res body in ok res + and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> @@ -145,8 +149,8 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e return @@ E_matching {matchee=e';cases=cases'} ) | E_record_accessor acc -> ( - let%bind e' = self acc.expr in - return @@ E_record_accessor {acc with expr = e'} + let%bind e' = self acc.record in + return @@ E_record_accessor {acc with record = e'} ) | E_record m -> ( let%bind m' = bind_map_lmap self m in @@ -166,10 +170,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind (lamb,args) = bind_map_pair self ab in return @@ E_application {lamb;args} ) - | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> ( + | E_let_in { let_binder ; rhs ; let_result; inline } -> ( let%bind rhs = self rhs in let%bind let_result = self let_result in - return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline } + return @@ E_let_in { let_binder ; rhs ; let_result; inline } ) | E_lambda { binder ; input_type ; output_type ; result } -> ( let%bind result = self result in @@ -187,6 +191,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in return @@ E_sequence {expr1;expr2} ) + | E_assign {variable;access_path;expression} -> ( + let%bind expression = self expression in + return @@ E_assign {variable;access_path;expression} + ) | E_for {binder; start; final; increment; body} -> let%bind body = self body in return @@ E_for {binder; start; final; increment; body} @@ -303,8 +311,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres ok (res, return @@ E_matching {matchee=e';cases=cases'}) ) | E_record_accessor acc -> ( - let%bind (res, e') = self init' acc.expr in - ok (res, return @@ E_record_accessor {acc with expr = e'}) + let%bind (res, e') = self init' acc.record in + ok (res, return @@ E_record_accessor {acc with record = e'}) ) | E_record m -> ( let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in @@ -325,10 +333,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in ok (res, return @@ E_application {lamb=a;args=b}) ) - | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> ( + | E_let_in { let_binder ; rhs ; let_result; inline } -> ( let%bind (res,rhs) = self init' rhs in let%bind (res,let_result) = self res let_result in - ok (res, return @@ E_let_in { let_binder ; mut; rhs ; let_result ; inline }) + ok (res, return @@ E_let_in { let_binder ; rhs ; let_result ; inline }) ) | E_lambda { binder ; input_type ; output_type ; result } -> ( let%bind (res,result) = self init' result in @@ -346,6 +354,9 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in ok (res, return @@ E_sequence {expr1;expr2}) ) + | E_assign {variable;access_path;expression} -> + let%bind (res, expression) = self init' expression in + ok (res, return @@ E_assign {variable;access_path;expression}) | E_for {binder; start; final; increment; body} -> let%bind (res, body) = self init' body in ok (res, return @@ E_for {binder; start; final; increment; body}) diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index a461dc9ae..33c56626b 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -37,7 +37,7 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result) else( let free_var = if (List.mem name free_var) then free_var else name::free_var in - let expr = O.e_let_in (env,None) false false (O.e_update (O.e_variable env) (Var.to_name name) (O.e_variable name)) let_result in + let expr = O.e_let_in (env,None) false false (O.e_record_update (O.e_variable env) (Var.to_name name) (O.e_variable name)) let_result in ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr) ) | E_constant {cons_name=C_MAP_FOLD;arguments= _} @@ -70,8 +70,8 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names : else( let free_var = if (List.mem name free_var) then free_var else name::free_var in let expr = O.e_let_in (env,None) false false ( - O.e_update (O.e_variable env) ("0") - (O.e_update (O.e_accessor (O.e_variable env) "0") (Var.to_name name) (O.e_variable name)) + O.e_record_update (O.e_variable env) ("0") + (O.e_record_update (O.e_record_accessor (O.e_variable env) "0") (Var.to_name name) (O.e_variable name)) ) let_result in ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr) @@ -95,7 +95,7 @@ and store_mutable_variable (free_vars : I.expression_variable list) = and restore_mutable_variable (expr : O.expression->O.expression_content) (free_vars : O.expression_variable list) (env : O.expression_variable) = let aux (f: O.expression -> O.expression) (ev: O.expression_variable) = - fun expr -> f (O.e_let_in (ev,None) true false (O.e_accessor (O.e_variable env) (Var.to_name ev)) expr) + fun expr -> f (O.e_let_in (ev,None) true false (O.e_record_accessor (O.e_variable env) (Var.to_name ev)) expr) in let ef = List.fold_left aux (fun e -> e) free_vars in expr (ef (O.e_skip ())) @@ -178,12 +178,12 @@ let rec compile_expression : I.expression -> O.expression result = let%bind fun_type = compile_type_expression fun_type in let%bind lambda = compile_lambda lambda in return @@ O.E_recursive {fun_name;fun_type;lambda} - | I.E_let_in {let_binder;mut;inline;rhs;let_result} -> + | I.E_let_in {let_binder;inline;rhs;let_result} -> let (binder,ty_opt) = let_binder in let%bind ty_opt = bind_map_option compile_type_expression ty_opt in let%bind rhs = compile_expression rhs in let%bind let_result = compile_expression let_result in - return @@ O.E_let_in {let_binder=(binder,ty_opt);mut;inline;rhs;let_result} + return @@ O.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} | I.E_constructor {constructor;element} -> let%bind element = compile_expression element in return @@ O.E_constructor {constructor;element} @@ -199,9 +199,9 @@ let rec compile_expression : I.expression -> O.expression result = ) record in return @@ O.E_record (O.LMap.of_list record) - | I.E_record_accessor {expr;label} -> - let%bind expr = compile_expression expr in - return @@ O.E_record_accessor {expr;label} + | I.E_record_accessor {record;label} -> + let%bind record = compile_expression record in + return @@ O.E_record_accessor {record;label} | I.E_record_update {record;path;update} -> let%bind record = compile_expression record in let%bind update = compile_expression update in @@ -231,11 +231,18 @@ let rec compile_expression : I.expression -> O.expression result = let%bind anno_expr = compile_expression anno_expr in let%bind type_annotation = compile_type_expression type_annotation in return @@ O.E_ascription {anno_expr; type_annotation} + | I.E_sequence {expr1={expression_content=I.E_assign expr1;_}; expr2} -> + let%bind expr2 = compile_expression expr2 in + let%bind ret = compile_assign expr1 @@ expr2 in + return @@ ret | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in ok @@ add_to_end expr1 expr2 | I.E_skip -> return @@ O.E_skip + | I.E_assign ass -> + let%bind content = compile_assign ass @@ O.e_skip () in + return @@ content | I.E_for f -> let%bind f = compile_for f in return @@ f @@ -246,6 +253,37 @@ let rec compile_expression : I.expression -> O.expression result = let%bind w = compile_while w in return @@ w +and compile_assign {variable; access_path; expression} expr = + let accessor ?loc s a = + match a with + I.Access_tuple _i -> failwith "adding tuple soon" + | I.Access_record a -> ok @@ O.e_record_accessor ?loc s a + | I.Access_map k -> + let%bind k = compile_expression k in + ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;s] + in + let update ?loc (s:O.expression) a e = + match a with + I.Access_tuple _i -> failwith "adding tuple soon" + | I.Access_record a -> ok @@ O.e_record_update ?loc s a e + | I.Access_map k -> + let%bind k = compile_expression k in + ok @@ O.e_constant ?loc C_UPDATE [k;O.e_some (e);s] + in + let aux (s, e : O.expression * _) lst = + let%bind s' = accessor ~loc:s.location s lst in + let e' = fun expr -> + let%bind u = update ~loc:s.location s lst (expr) + in e u + in + ok @@ (s',e') + in + let%bind (_,rhs) = bind_fold_list aux (O.e_variable variable, fun e -> ok @@ e) access_path in + let%bind expression = compile_expression expression in + let%bind rhs = rhs @@ expression in + ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false} + + and compile_lambda : I.lambda -> O.lambda result = fun {binder;input_type;output_type;result}-> let%bind input_type = bind_map_option compile_type_expression input_type in @@ -362,7 +400,7 @@ and compile_while I.{condition;body} = let for_body = add_to_end for_body ctrl in let aux name expr= - O.e_let_in (name,None) false false (O.e_accessor (O.e_accessor (O.e_variable binder) "0") (Var.to_name name)) expr + O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable binder) "0") (Var.to_name name)) expr in let init_rec = O.e_tuple [store_mutable_variable @@ captured_name_list] in let restore = fun expr -> List.fold_right aux captured_name_list expr in @@ -377,7 +415,7 @@ and compile_while I.{condition;body} = let return_expr = fun expr -> O.E_let_in {let_binder; mut=false; inline=false; rhs=init_rec; let_result= O.e_let_in let_binder false false loop @@ - O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) "0") @@ + O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) "0") @@ expr } in @@ -393,7 +431,7 @@ and compile_for I.{binder;start;final;increment;body} = let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in let ctrl = O.e_let_in (binder,Some O.t_int) false false (O.e_constant C_ADD [ O.e_variable binder ; step ]) @@ - O.e_let_in (env_rec, None) false false (O.e_update (O.e_variable env_rec) "1" @@ O.e_variable binder)@@ + O.e_let_in (env_rec, None) false false (O.e_record_update (O.e_variable env_rec) "1" @@ O.e_variable binder)@@ continue_expr in (* Modify the body loop*) @@ -402,7 +440,7 @@ and compile_for I.{binder;start;final;increment;body} = let for_body = add_to_end for_body ctrl in let aux name expr= - O.e_let_in (name,None) false false (O.e_accessor (O.e_accessor (O.e_variable env_rec) "0") (Var.to_name name)) expr + O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable env_rec) "0") (Var.to_name name)) expr in (* restores the initial value of the free_var*) @@ -411,7 +449,7 @@ and compile_for I.{binder;start;final;increment;body} = (*Prep the lambda for the fold*) let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in let aux_func = O.e_lambda env_rec None None @@ - O.e_let_in (binder,Some O.t_int) false false (O.e_accessor (O.e_variable env_rec) "1") @@ + O.e_let_in (binder,Some O.t_int) false false (O.e_record_accessor (O.e_variable env_rec) "1") @@ O.e_cond cond (restore for_body) (stop_expr) in (* Make the fold_while en precharge the vakye *) @@ -424,7 +462,7 @@ and compile_for I.{binder;start;final;increment;body} = O.E_let_in {let_binder=(binder, Some O.t_int);mut=false; inline=false;rhs=start;let_result= O.e_let_in let_binder false false init_rec @@ O.e_let_in let_binder false false loop @@ - O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) "0") @@ + O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) "0") @@ expr } in @@ -440,21 +478,21 @@ and compile_for_each I.{binder;collection;collection_type; body} = let env = Var.fresh () in let%bind body = compile_expression body in let%bind ((_,free_vars), body) = repair_mutable_variable_in_loops body element_names args in - let for_body = add_to_end body @@ (O.e_accessor (O.e_variable args) "0") in + let for_body = add_to_end body @@ (O.e_record_accessor (O.e_variable args) "0") in let init_record = store_mutable_variable free_vars in let%bind collect = compile_expression collection in let aux name expr= - O.e_let_in (name,None) false false (O.e_accessor (O.e_accessor (O.e_variable args) "0") (Var.to_name name)) expr + O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "0") (Var.to_name name)) expr in let restore = fun expr -> List.fold_right aux free_vars expr in let restore = match collection_type with | Map -> (match snd binder with - | Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_accessor (O.e_variable args) "1") "0") - (O.e_let_in (v, None) false false (O.e_accessor (O.e_accessor (O.e_variable args) "1") "1") expr)) - | None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_accessor (O.e_variable args) "1") "0") expr) + | Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "0") + (O.e_let_in (v, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "1") expr)) + | None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "0") expr) ) - | _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_variable args) "1") expr) + | _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_variable args) "1") expr) in let lambda = O.e_lambda args None None (restore for_body) in let%bind op_name = match collection_type with @@ -564,7 +602,7 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in let%bind rhs = uncompile_expression rhs in let%bind let_result = uncompile_expression let_result in - return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} + return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} | O.E_constructor {constructor;element} -> let%bind element = uncompile_expression element in return @@ I.E_constructor {constructor;element} @@ -581,9 +619,9 @@ let rec uncompile_expression : O.expression -> I.expression result = ) record in return @@ I.E_record (O.LMap.of_list record) - | O.E_record_accessor {expr;label} -> - let%bind expr = uncompile_expression expr in - return @@ I.E_record_accessor {expr;label} + | O.E_record_accessor {record;label} -> + let%bind record = uncompile_expression record in + return @@ I.E_record_accessor {record;label} | O.E_record_update {record;path;update} -> let%bind record = uncompile_expression record in let%bind update = uncompile_expression update in diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml index 71597ce5e..0e0ddbd45 100644 --- a/src/passes/5-self_ast_sugar/helpers.ml +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -47,8 +47,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = fold_expression self res update in ok res ) - | E_record_accessor {expr} -> ( - let%bind res = self init' expr in + | E_record_accessor {record} -> ( + let%bind res = self init' record in ok res ) | E_let_in { let_binder = _ ; rhs ; let_result } -> ( @@ -134,8 +134,8 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e return @@ E_matching {matchee=e';cases=cases'} ) | E_record_accessor acc -> ( - let%bind e' = self acc.expr in - return @@ E_record_accessor {acc with expr = e'} + let%bind e' = self acc.record in + return @@ E_record_accessor {acc with record = e'} ) | E_record m -> ( let%bind m' = bind_map_lmap self m in @@ -280,8 +280,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres ok (res, return @@ E_matching {matchee=e';cases=cases'}) ) | E_record_accessor acc -> ( - let%bind (res, e') = self init' acc.expr in - ok (res, return @@ E_record_accessor {acc with expr = e'}) + let%bind (res, e') = self init' acc.record in + ok (res, return @@ E_record_accessor {acc with record = e'}) ) | E_record m -> ( let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 48c43f6d7..e75b9c2ff 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -101,9 +101,9 @@ let rec compile_expression : I.expression -> O.expression result = ) record in return @@ O.E_record (O.LMap.of_list record) - | I.E_record_accessor {expr;label} -> - let%bind expr = compile_expression expr in - return @@ O.E_record_accessor {expr;label} + | I.E_record_accessor {record;label} -> + let%bind record = compile_expression record in + return @@ O.E_record_accessor {record;label} | I.E_record_update {record;path;update} -> let%bind record = compile_expression record in let%bind update = compile_expression update in @@ -294,9 +294,9 @@ let rec uncompile_expression : O.expression -> I.expression result = ) record in return @@ I.E_record (O.LMap.of_list record) - | O.E_record_accessor {expr;label} -> - let%bind expr = uncompile_expression expr in - return @@ I.E_record_accessor {expr;label} + | O.E_record_accessor {record;label} -> + let%bind record = uncompile_expression record in + return @@ I.E_record_accessor {record;label} | O.E_record_update {record;path;update} -> let%bind record = uncompile_expression record in let%bind update = uncompile_expression update in diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 0dcae68d0..f446c1076 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -452,10 +452,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - * | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ()) * | _ -> return (E_literal (Literal_string s)) (t_string ()) * ) *) - | E_record_accessor {expr;label} -> ( - let%bind (base' , state') = type_expression e state expr in + | E_record_accessor {record;label} -> ( + let%bind (base' , state') = type_expression e state record in let wrapped = Wrap.access_label ~base:base'.type_expression ~label in - return_wrapped (E_record_accessor {expr=base';label}) state' wrapped + return_wrapped (E_record_accessor {record=base';label}) state' wrapped ) (* Sum *) @@ -1055,8 +1055,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind r' = bind_smap @@ Map.String.map untype_expression r in return (e_record r') - | E_record_accessor {expr; label} -> - let%bind r' = untype_expression expr in + | E_record_accessor {record; label} -> + let%bind r' = untype_expression record in let Label s = label in return (e_accessor r' s) | E_record_update {record; path; update} -> diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 5a11d6184..d26828230 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -450,8 +450,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression return (e_address s) (t_address ()) | E_literal (Literal_operation op) -> return (e_operation op) (t_operation ()) - | E_record_accessor {expr;label} -> - let%bind e' = type_expression' e expr in + | E_record_accessor {record;label} -> + let%bind e' = type_expression' e record in let aux (prev:O.expression) (a:I.label) : O.expression result = let property = a in let%bind r_tv = get_t_record prev.type_expression in @@ -459,7 +459,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression generic_try (bad_record_access property ae prev.type_expression ae.location) @@ (fun () -> I.LMap.find property r_tv) in let location = ae.location in - ok @@ make_a_e ~location (E_record_accessor {expr=prev; label=property}) tv e + ok @@ make_a_e ~location (E_record_accessor {record=prev; label=property}) tv e in let%bind ae = trace (simple_info "accessing") @@ aux e' label in @@ -861,8 +861,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind r' = bind_smap @@ Map.String.map untype_expression r in return (e_record r') - | E_record_accessor {expr; label} -> - let%bind r' = untype_expression expr in + | E_record_accessor {record; label} -> + let%bind r' = untype_expression record in let Label s = label in return (e_accessor r' s) | E_record_update {record=r; path=l; update=e} -> diff --git a/src/passes/9-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml index 2da8a766e..90a9fe9cc 100644 --- a/src/passes/9-self_ast_typed/helpers.ml +++ b/src/passes/9-self_ast_typed/helpers.ml @@ -48,8 +48,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = fold_expression self res update in ok res ) - | E_record_accessor {expr} -> ( - let%bind res = self init' expr in + | E_record_accessor {record} -> ( + let%bind res = self init' record in ok res ) | E_let_in { let_binder = _ ; rhs ; let_result } -> ( @@ -119,8 +119,8 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> return @@ E_matching {matchee=e';cases=cases'} ) | E_record_accessor acc -> ( - let%bind e' = self acc.expr in - return @@ E_record_accessor {acc with expr = e'} + let%bind e' = self acc.record in + return @@ E_record_accessor {acc with record = e'} ) | E_record m -> ( let%bind m' = bind_map_lmap self m in @@ -234,8 +234,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres ok (res, return @@ E_matching {matchee=e';cases=cases'}) ) | E_record_accessor acc -> ( - let%bind (res, e') = self init' acc.expr in - ok (res, return @@ E_record_accessor {acc with expr = e'}) + let%bind (res, e') = self init' acc.record in + ok (res, return @@ E_record_accessor {acc with record = e'}) ) | E_record m -> ( let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in diff --git a/src/passes/9-self_ast_typed/tail_recursion.ml b/src/passes/9-self_ast_typed/tail_recursion.ml index 610484a38..5e3953bc3 100644 --- a/src/passes/9-self_ast_typed/tail_recursion.ml +++ b/src/passes/9-self_ast_typed/tail_recursion.ml @@ -49,8 +49,8 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> unit let es = LMap.to_list elm in let%bind _ = bind_map_list (check_recursive_call n false) es in ok () - | E_record_accessor {expr;_} -> - let%bind _ = check_recursive_call n false expr in + | E_record_accessor {record;_} -> + let%bind _ = check_recursive_call n false record in ok () | E_record_update {record;update;_} -> let%bind _ = check_recursive_call n false record in diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index d25b84dee..1c8a243ff 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -27,8 +27,8 @@ and expression_content ppf (ec : expression_content) = c.arguments | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m - | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.expr label ra.label + | E_record_accessor {record; label=l}-> + fprintf ppf "%a.%a" expression record label l | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update | E_map m -> @@ -57,15 +57,20 @@ and expression_content ppf (ec : expression_content) = expression_variable fun_name type_expression fun_type expression_content (E_lambda lambda) - | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> - fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result + | E_let_in { let_binder ; rhs ; let_result; inline } -> + fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation | E_sequence {expr1;expr2} -> - fprintf ppf "%a;\n%a" expression expr1 expression expr2 + fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_skip -> fprintf ppf "skip" + | E_assign {variable; access_path; expression=e} -> + fprintf ppf "%a%a := %a" + expression_variable variable + (list_sep (fun ppf a -> fprintf ppf ".%a" accessor a) (fun ppf () -> fprintf ppf "")) access_path + expression e | E_for {binder; start; final; increment; body} -> fprintf ppf "for %a from %a to %a by %a do %a" expression_variable binder @@ -83,6 +88,12 @@ and expression_content ppf (ec : expression_content) = expression condition expression body +and accessor ppf a = + match a with + | Access_tuple i -> fprintf ppf "%d" i + | Access_record s -> fprintf ppf "%s" s + | Access_map e -> fprintf ppf "%a" expression e + and option_map ppf (k,v_opt) = match v_opt with | None -> fprintf ppf "%a" expression_variable k diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 47ec55fb6..bc66d4ac0 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -118,12 +118,12 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} +let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_skip ?loc () = make_expr ?loc @@ E_skip -let e_let_in ?loc (binder, ascr) mut inline rhs let_result = - make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline } +let e_let_in ?loc (binder, ascr) inline rhs let_result = + make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline } let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b} let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} @@ -191,24 +191,16 @@ let e_lambda ?loc (binder : expression_variable) let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} -let e_assign_with_let ?loc var access_path expr = - let var = Var.of_name (var) in - match access_path with - | [] -> (var, None), true, expr, false - - | lst -> - let rec aux path record= match path with - | [] -> failwith "acces_path cannot be empty" - | [e] -> e_update ?loc record e expr - | elem::tail -> - let next_record = e_accessor record elem in - e_update ?loc record elem (aux tail next_record ) - in - (var, None), true, (aux lst (e_variable var)), false +let e_assign ?loc variable access_path expression = + make_expr ?loc @@ E_assign {variable;access_path;expression} +let e_ez_assign ?loc variable access_path expression = + let variable = Var.of_name variable in + let access_path = List.map (fun s -> Access_record s) access_path in + e_assign ?loc variable access_path expression let get_e_accessor = fun t -> match t with - | E_record_accessor {expr; label} -> ok (expr , label) + | E_record_accessor {record; label} -> ok (record , label) | _ -> simple_fail "not an accessor" let assert_e_accessor = fun t -> diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index 4d5c4db7a..1cf5986c9 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -86,7 +86,7 @@ val e_variable : ?loc:Location.t -> expression_variable -> expression val e_skip : ?loc:Location.t -> unit -> expression val e_sequence : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression -val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression +val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression val e_application : ?loc:Location.t -> expression -> expression -> expression val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression @@ -110,7 +110,8 @@ val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression val e_update : ?loc:Location.t -> expression -> string -> expression -> expression -val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) +val e_assign : ?loc:Location.t -> expression_variable -> access list -> expression -> expression +val e_ez_assign : ?loc:Location.t -> string -> string list -> expression -> expression (* val get_e_accessor : expression' -> ( expression * access_path ) result diff --git a/src/stages/1-ast_imperative/misc.ml b/src/stages/1-ast_imperative/misc.ml index 54e0303cf..7a2615e04 100644 --- a/src/stages/1-ast_imperative/misc.ml +++ b/src/stages/1-ast_imperative/misc.ml @@ -185,6 +185,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_recursive _,_) | (E_record_accessor _, _) | (E_look_up _, _) | (E_matching _, _) | (E_sequence _, _) | (E_skip, _) + | (E_assign _, _) | (E_for _, _) | (E_for_each _, _) | (E_while _, _) -> simple_fail "comparing not a value" diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 08200dbd7..480d612fb 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -55,6 +55,7 @@ and expression_content = | E_set of expression list | E_look_up of (expression * expression) (* Imperative *) + | E_assign of assign | E_for of for_ | E_for_each of for_each | E_while of while_loop @@ -82,14 +83,13 @@ and recursive = { and let_in = { let_binder: expression_variable * type_expression option - ; mut: bool ; rhs: expression ; let_result: expression ; inline: bool } and constructor = {constructor: constructor'; element: expression} -and accessor = {expr: expression; label: label} +and accessor = {record: expression; label: label} and update = {record: expression; path: label ; update: expression} @@ -105,6 +105,17 @@ and sequence = { expr2: expression ; } +and assign = { + variable : expression_variable; + access_path : access list; + expression : expression; +} + +and access = + | Access_tuple of int + | Access_record of string + | Access_map of expr + and for_ = { binder : expression_variable; start : expression; diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index 1b65a8046..ca4184aff 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -28,7 +28,7 @@ and expression_content ppf (ec : expression_content) = | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.expr label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.label | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update | E_map m -> @@ -64,7 +64,7 @@ and expression_content ppf (ec : expression_content) = option_inline inline expression let_result | E_sequence {expr1;expr2} -> - fprintf ppf "{ %a; %a }" expression expr1 expression expr2 + fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation | E_skip -> diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index f53344c37..d5099ab28 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -107,33 +107,27 @@ let e_bytes_raw ?loc (b: bytes) : expression = make_expr ?loc @@ E_literal (Literal_bytes b) let e_bytes_string ?loc (s: string) : expression = make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) -let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]} let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []} -let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]} -let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]} -let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst -let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst -let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} -let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v -let e_skip ?loc () = make_expr ?loc @@ E_skip let e_let_in ?loc (binder, ascr) mut inline rhs let_result = make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut } -let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b} -let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]} let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst} -let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y) + +let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} + let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2} -let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) -(* -let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) -*) +let e_skip ?loc () = make_expr ?loc @@ E_skip + +let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst +let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst +let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst +let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst + let ez_match_variant (lst : ((string * string) * 'a) list) = let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in Match_variant (lst,()) @@ -145,19 +139,20 @@ let e_record_ez ?loc (lst : (string * expr) list) : expression = let e_record ?loc map = let lst = Map.String.to_kv_list map in e_record_ez ?loc lst +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} -let e_update ?loc record path update = +let e_record_update ?loc record path update = let path = Label path in make_expr ?loc @@ E_record_update {record; path; update} -let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) -let e_pair ?loc a b : expression = e_tuple ?loc [a;b] - let make_option_typed ?loc e t_opt = match t_opt with | None -> e | Some t -> e_annotation ?loc e t +let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) +let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) +let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_typed_none ?loc t_opt = let type_annotation = t_option t_opt in @@ -185,25 +180,9 @@ let e_lambda ?loc (binder : expression_variable) } let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} - -let e_assign_with_let ?loc var access_path expr = - let var = Var.of_name (var) in - match access_path with - | [] -> (var, None), true, expr, false - - | lst -> - let rec aux path record= match path with - | [] -> failwith "acces_path cannot be empty" - | [e] -> e_update ?loc record e expr - | elem::tail -> - let next_record = e_accessor record elem in - e_update ?loc record elem (aux tail next_record ) - in - (var, None), true, (aux lst (e_variable var)), false - let get_e_accessor = fun t -> match t with - | E_record_accessor {expr; label} -> ok (expr , label) + | E_record_accessor {record; label} -> ok (record , label) | _ -> simple_fail "not an accessor" let assert_e_accessor = fun t -> diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index ca2f2d552..d790512f6 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -65,34 +65,34 @@ val e'_bytes : string -> expression_content result val e_bytes_hex : ?loc:Location.t -> string -> expression result val e_bytes_raw : ?loc:Location.t -> bytes -> expression val e_bytes_string : ?loc:Location.t -> string -> expression -val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression - -val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression -val e_tuple : ?loc:Location.t -> expression list -> expression val e_some : ?loc:Location.t -> expression -> expression val e_none : ?loc:Location.t -> unit -> expression -val e_string_cat : ?loc:Location.t -> expression -> expression -> expression -val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression -val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression -val e_set : ?loc:Location.t -> expression list -> expression -val e_list : ?loc:Location.t -> expression list -> expression -val e_pair : ?loc:Location.t -> expression -> expression -> expression + +val e_variable : ?loc:Location.t -> expression_variable -> expression val e_constructor : ?loc:Location.t -> string -> expression -> expression +val e_constant : ?loc:Location.t -> constant' -> expression list -> expression + +val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression +val e_application : ?loc:Location.t -> expression -> expression -> expression +val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression +val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression + +val e_record : ?loc:Location.t -> expr Map.String.t -> expression +val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression +val e_record_accessor : ?loc:Location.t -> expression -> string -> expression + +val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression + +val e_sequence : ?loc:Location.t -> expression -> expression -> expression +val e_skip : ?loc:Location.t -> unit -> expression + +val e_list : ?loc:Location.t -> expression list -> expression +val e_set : ?loc:Location.t -> expression list -> expression +val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression +val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression + val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression -val e_accessor : ?loc:Location.t -> expression -> string -> expression -val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression -val e_variable : ?loc:Location.t -> expression_variable -> expression -val e_skip : ?loc:Location.t -> unit -> expression -val e_sequence : ?loc:Location.t -> expression -> expression -> expression -val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression -val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression -val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression -val e_application : ?loc:Location.t -> expression -> expression -> expression -val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression -val e_constant : ?loc:Location.t -> constant' -> expression list -> expression -val e_look_up : ?loc:Location.t -> expression -> expression -> expression -val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression @@ -103,15 +103,12 @@ val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expr val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression - val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression -val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression -val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression -val e_record : ?loc:Location.t -> expr Map.String.t -> expression -val e_update : ?loc:Location.t -> expression -> string -> expression -> expression -val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) - +val e_record_ez : ?loc:Location.t -> (string * expression) list -> expression +val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression +val e_tuple : ?loc:Location.t -> expression list -> expression +val e_pair : ?loc:Location.t -> expression -> expression -> expression (* val get_e_accessor : expression' -> ( expression * access_path ) result *) diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 658d30e35..5ad052e46 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -86,7 +86,7 @@ and let_in = { and constructor = {constructor: constructor'; element: expression} -and accessor = {expr: expression; label: label} +and accessor = {record: expression; label: label} and update = {record: expression; path: label ; update: expression} diff --git a/src/stages/3-ast_core/PP.ml b/src/stages/3-ast_core/PP.ml index 3410a96fb..0d648065e 100644 --- a/src/stages/3-ast_core/PP.ml +++ b/src/stages/3-ast_core/PP.ml @@ -28,7 +28,7 @@ and expression_content ppf (ec : expression_content) = | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.expr label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.label | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update | E_map m -> diff --git a/src/stages/3-ast_core/combinators.ml b/src/stages/3-ast_core/combinators.ml index db2417902..90d1cebd8 100644 --- a/src/stages/3-ast_core/combinators.ml +++ b/src/stages/3-ast_core/combinators.ml @@ -118,7 +118,7 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b} +let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_let_in ?loc (binder, ascr) inline rhs let_result = @@ -201,7 +201,7 @@ let e_assign_with_let ?loc var access_path expr = let get_e_accessor = fun t -> match t with - | E_record_accessor {expr; label} -> ok (expr , label) + | E_record_accessor {record; label} -> ok (record , label) | _ -> simple_fail "not an accessor" let assert_e_accessor = fun t -> diff --git a/src/stages/3-ast_core/types.ml b/src/stages/3-ast_core/types.ml index 2b8f0dbc2..81ba90fa2 100644 --- a/src/stages/3-ast_core/types.ml +++ b/src/stages/3-ast_core/types.ml @@ -82,7 +82,7 @@ and let_in = and constructor = {constructor: constructor'; element: expression} -and accessor = {expr: expression; label: label} +and accessor = {record: expression; label: label} and update = {record: expression; path: label ; update: expression} diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 1325d0476..ab655c80b 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -29,7 +29,7 @@ and expression_content ppf (ec: expression_content) = | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.expr label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.label | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update | E_map m -> diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index 014ab8f2f..5abb2a2bc 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -337,7 +337,7 @@ let get_a_bool (t:expression) = let get_a_record_accessor = fun t -> match t.expression_content with - | E_record_accessor {expr ; label} -> ok (expr , label) + | E_record_accessor {record ; label} -> ok (record , label) | _ -> simple_fail "not an accessor" let get_declaration_by_name : program -> string -> declaration result = fun p name -> diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 04efcca5f..533520fe7 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -209,7 +209,7 @@ module Free_variables = struct | E_application {lamb;args} -> unions @@ List.map self [ lamb ; args ] | E_constructor {element;_} -> self element | E_record m -> unions @@ List.map self @@ LMap.to_list m - | E_record_accessor {expr;_} -> self expr + | E_record_accessor {record;_} -> self record | E_record_update {record; update;_} -> union (self record) @@ self update | E_list lst -> unions @@ List.map self lst | E_set lst -> unions @@ List.map self lst diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index 0040f7d90..1d1110a1c 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -70,7 +70,7 @@ module Captured_variables = struct | E_record m -> let%bind lst' = bind_map_list self @@ LMap.to_list m in ok @@ unions lst' - | E_record_accessor {expr;_} -> self expr + | E_record_accessor {record;_} -> self record | E_record_update {record;update;_} -> let%bind r = self record in let%bind e = self update in diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index fdb24969b..5fbe79554 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -92,7 +92,7 @@ and constructor = { } and accessor = { - expr: expression ; + record: expression ; label: label ; } diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 4b60cf454..affe9fd37 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -182,10 +182,10 @@ module Substitution = struct * let val_ = s_expression ~v ~expr val_ in * ok @@ (key , val_)) aemap in * ok @@ T.E_record aemap *) - | T.E_record_accessor {expr=e;label} -> - let%bind expr = s_expression ~substs e in + | T.E_record_accessor {record=e;label} -> + let%bind record = s_expression ~substs e in let%bind label = s_label ~substs label in - ok @@ T.E_record_accessor {expr;label} + ok @@ T.E_record_accessor {record;label} | T.E_record_update {record;path;update}-> let%bind record = s_expression ~substs record in let%bind update = s_expression ~substs update in diff --git a/src/test/multisig_v2_tests.ml b/src/test/multisig_v2_tests.ml index 8b2b8972b..24912c289 100644 --- a/src/test/multisig_v2_tests.ml +++ b/src/test/multisig_v2_tests.ml @@ -33,7 +33,7 @@ let empty_message = e_lambda (Var.of_name "arguments") empty_op_list let empty_message2 = e_lambda (Var.of_name "arguments") (Some t_bytes) (Some (t_list t_operation)) - ( e_let_in ((Var.of_name "foo"),Some t_unit) false false (e_unit ()) empty_op_list) + ( e_let_in ((Var.of_name "foo"),Some t_unit) false (e_unit ()) empty_op_list) let send_param msg = e_constructor "Send" msg let withdraw_param = e_constructor "Withdraw" empty_message From d91753e4934618726a7f96427b8047b25747791b Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Mon, 30 Mar 2020 14:40:28 +0200 Subject: [PATCH 2/2] remove case e_sequance (e_assing, expr) --- src/bin/expect_tests/contract_tests.ml | 4 ++-- src/passes/4-imperative_to_sugar/imperative_to_sugar.ml | 4 ---- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 3e78f213c..311d96b41 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -1114,7 +1114,7 @@ let%expect_test _ = let%expect_test _ = run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#701 = #P in let p = rhs#701.0 in let s = rhs#701.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} +ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#702 = #P in let p = rhs#702.0 in let s = rhs#702.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} If you're not sure how to fix this error, you can @@ -1127,7 +1127,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#704 = #P in let p = rhs#704.0 in let s = rhs#704.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} +ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#705 = #P in let p = rhs#705.0 in let s = rhs#705.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} If you're not sure how to fix this error, you can diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 33c56626b..2ac37fc71 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -231,10 +231,6 @@ let rec compile_expression : I.expression -> O.expression result = let%bind anno_expr = compile_expression anno_expr in let%bind type_annotation = compile_type_expression type_annotation in return @@ O.E_ascription {anno_expr; type_annotation} - | I.E_sequence {expr1={expression_content=I.E_assign expr1;_}; expr2} -> - let%bind expr2 = compile_expression expr2 in - let%bind ret = compile_assign expr1 @@ expr2 in - return @@ ret | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in