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

add assign back

Browse Source
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-03-23 16:00:50 +01:00
parent 63793ddc76
commit 21e8298a4e
31 changed files with 242 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/passes/10-interpreter/interpreter.ml
View File

@ -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") @@

9
src/passes/10-transpiler/transpiler.ml
View File

@ -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} ->

9
src/passes/2-concrete_to_imperative/cameligo.ml
View File

@ -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 ()

40
src/passes/2-concrete_to_imperative/pascaligo.ml
View File

@ -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 ->

31
src/passes/3-self_ast_imperative/helpers.ml
View File

@ -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
@ -76,6 +79,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with
| Match_bool { match_true ; match_false } -> (
@ -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})

88
src/passes/4-imperative_to_sugar/imperative_to_sugar.ml
View File

@ -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

12
src/passes/5-self_ast_sugar/helpers.ml
View File

@ -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

12
src/passes/6-sugar_to_core/sugar_to_core.ml
View File

@ -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

10
src/passes/8-typer-new/typer.ml
View File

@ -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} ->

10
src/passes/8-typer-old/typer.ml
View File

@ -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} ->

12
src/passes/9-self_ast_typed/helpers.ml
View File

@ -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

4
src/passes/9-self_ast_typed/tail_recursion.ml
View File

@ -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

21
src/stages/1-ast_imperative/PP.ml
View File

@ -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

28
src/stages/1-ast_imperative/combinators.ml
View File

@ -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 ->

5
src/stages/1-ast_imperative/combinators.mli
View File

@ -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

1
src/stages/1-ast_imperative/misc.ml
View File

@ -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"

15
src/stages/1-ast_imperative/types.ml
View File

@ -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;

4
src/stages/2-ast_sugar/PP.ml
View File

@ -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 ->

53
src/stages/2-ast_sugar/combinators.ml
View File

@ -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 ->

57
src/stages/2-ast_sugar/combinators.mli
View File

@ -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
*)

2
src/stages/2-ast_sugar/types.ml
View File

@ -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}

2
src/stages/3-ast_core/PP.ml
View File

@ -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 ->

4
src/stages/3-ast_core/combinators.ml
View File

@ -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 ->

2
src/stages/3-ast_core/types.ml
View File

@ -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}

2
src/stages/4-ast_typed/PP.ml
View File

@ -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 ->

2
src/stages/4-ast_typed/combinators.ml
View File

@ -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 ->

2
src/stages/4-ast_typed/misc.ml
View File

@ -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

2
src/stages/4-ast_typed/misc_smart.ml
View File

@ -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

2
src/stages/4-ast_typed/types.ml
View File

@ -92,7 +92,7 @@ and constructor = {
}
and accessor = {
expr: expression ;
record: expression ;
label: label ;
}

6
src/stages/typesystem/misc.ml
View File

@ -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

2
src/test/multisig_v2_tests.ml
View File

@ -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