diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 984a0163b..3e78f213c 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -10,10 +10,10 @@ let%expect_test _ = [%expect {| 1870 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ; - [%expect {| 1324 bytes |}] ; + [%expect {| 1294 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig-v2.ligo" ; "main" ] ; - [%expect {| 3231 bytes |}] ; + [%expect {| 2935 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ; [%expect {| 589 bytes |}] ; @@ -312,11 +312,8 @@ let%expect_test _ = SWAP ; CAR ; CDR ; - DUP ; - DIP { DIP 2 { DUP } ; DIG 2 } ; - PAIR ; - DIP { DIP { DUP } ; SWAP } ; - PAIR ; + DIP { DUP } ; + SWAP ; DIP 3 { DUP } ; DIG 3 ; CAR ; @@ -333,31 +330,31 @@ let%expect_test _ = PAIR ; DUP ; CAR ; - CAR ; + CDR ; DIP { DUP } ; SWAP ; CAR ; - CDR ; + CAR ; DIP 2 { DUP } ; DIG 2 ; CDR ; - DIP 2 { DUP } ; - DIG 2 ; - DIP { DIP { DUP } ; SWAP } ; + DIP { DUP } ; + SWAP ; + DIP { DIP 2 { DUP } ; DIG 2 } ; PAIR ; - DIP 3 { DUP } ; - DIG 3 ; + DIP 2 { DUP } ; + DIG 2 ; IF_CONS - { DIP 4 { DUP } ; - DIG 4 ; + { DIP 5 { DUP } ; + DIG 5 ; DIP 4 { DUP } ; DIG 4 ; CAR ; DIP { DIP { DUP } ; SWAP ; HASH_KEY } ; COMPARE ; EQ ; - IF { DIP 5 { DUP } ; - DIG 5 ; + IF { DIP 6 { DUP } ; + DIG 6 ; DIP 2 { DUP } ; DIG 2 ; DIP { DIP 5 { DUP } ; @@ -371,8 +368,8 @@ let%expect_test _ = PAIR ; PACK } } ; CHECK_SIGNATURE ; - IF { DIP 6 { DUP } ; - DIG 6 ; + IF { DIP 7 { DUP } ; + DIG 7 ; PUSH nat 1 ; ADD ; DIP { DUP } ; @@ -407,9 +404,10 @@ let%expect_test _ = CAR ; DIP 2 { DUP } ; DIG 2 ; + CAR ; + SWAP ; CDR ; SWAP ; - CAR ; PAIR ; SWAP ; CDR ; @@ -421,10 +419,9 @@ let%expect_test _ = CAR ; DIP 3 { DUP } ; DIG 3 ; - CAR ; - SWAP ; CDR ; SWAP ; + CAR ; PAIR ; SWAP ; CDR ; @@ -460,16 +457,14 @@ let%expect_test _ = DIP { DROP 2 } } ; DIP 3 { DUP } ; DIG 3 ; - CAR ; DIP { DUP } ; - PAIR ; - DIP { DROP 3 } } ; - DUP ; - CAR ; - CAR ; + SWAP ; + DIP { DROP 4 } } ; + DIP 2 { DUP } ; + DIG 2 ; UNIT ; EXEC ; - DIP { DUP ; CDR } ; + DIP { DUP } ; PAIR ; DIP { DROP 7 } } } |} ] @@ -628,13 +623,9 @@ let%expect_test _ = GT ; IF { PUSH string "Maximum number of proposal reached" ; FAILWITH } { PUSH unit Unit } ; - DIP 8 { DUP } ; - DIG 8 ; - DIP { DIP 3 { DUP } ; DIG 3 } ; - PAIR ; - DIP { DIP 7 { DUP } ; DIG 7 ; NIL operation ; SWAP ; PAIR } ; - PAIR ; - DIP { DIP 2 { DUP } ; DIG 2 } ; + DIP 2 { DUP } ; + DIG 2 ; + NIL operation ; PAIR ; DIP 4 { DUP } ; DIG 4 ; @@ -689,32 +680,26 @@ let%expect_test _ = SWAP ; CDR ; CAR ; - DIP 2 { DUP } ; - DIG 2 ; - CDR ; - CDR ; DIP { DUP } ; SWAP ; DIP { DUP } ; - PAIR ; - DIP { DIP 2 { DUP } ; DIG 2 } ; - PAIR ; - DIP 2 { DUP } ; - DIG 2 ; - DIP { DIP 12 { DUP } ; DIG 12 } ; + SWAP ; + DIP { DIP 11 { DUP } ; DIG 11 } ; MEM ; - IF { DIP 3 { DUP } ; - DIG 3 ; - DIP 3 { DUP } ; - DIG 3 ; - DIP { DIP 2 { DUP } ; - DIG 2 ; + IF { DIP 2 { DUP } ; + DIG 2 ; + DIP 2 { DUP } ; + DIG 2 ; + DIP { DIP 4 { DUP } ; + DIG 4 ; + CDR ; + CDR ; PUSH nat 1 ; SWAP ; SUB ; ABS ; SOME ; - DIP { DIP 4 { DUP } ; DIG 4 ; CDR ; CAR ; CAR } } ; + DIP { DIP 3 { DUP } ; DIG 3 ; CDR ; CAR ; CAR } } ; UPDATE ; DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ; PAIR ; @@ -723,23 +708,21 @@ let%expect_test _ = PAIR ; DIP { DUP } ; SWAP ; - CAR ; DIP { DUP } ; - PAIR ; - DIP { DROP } } + SWAP ; + DIP { DROP 2 } } { DUP } ; + DIP 4 { DUP } ; + DIG 4 ; DIP 5 { DUP } ; DIG 5 ; - DIP 6 { DUP } ; - DIG 6 ; CAR ; DIP 2 { DUP } ; DIG 2 ; - CDR ; DIP { DROP ; CDR } ; PAIR ; CAR ; - DIP { DROP 6 } } ; + DIP { DROP 5 } } ; DIP 4 { DUP } ; DIG 4 ; DIP 4 { DUP } ; @@ -749,12 +732,10 @@ let%expect_test _ = PAIR ; DIP 3 { DUP } ; DIG 3 ; - DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ; SWAP ; - PAIR ; + CDR ; SWAP ; PAIR ; - PAIR ; DIP 2 { DUP } ; DIG 2 ; SWAP ; @@ -785,8 +766,6 @@ let%expect_test _ = PAIR } ; DUP ; CAR ; - CDR ; - CDR ; DIP { DUP ; CDR } ; PAIR ; DIP { DROP 15 } } ; @@ -800,9 +779,8 @@ let%expect_test _ = SWAP ; CAR ; PACK ; - DUP ; - DIP { DIP { DUP } ; SWAP } ; - PAIR ; + DIP { DUP } ; + SWAP ; DIP { DUP } ; SWAP ; DIP { DIP 2 { DUP } ; DIG 2 ; CAR ; CDR ; CDR } ; @@ -851,12 +829,7 @@ let%expect_test _ = DIP { DROP 2 } } { DUP } ; DUP ; - DIP 3 { DUP } ; - DIG 3 ; - DIP { DIP 6 { DUP } ; DIG 6 } ; - PAIR ; - DIP { DUP } ; - PAIR ; + DUP ; DIP 4 { DUP } ; DIG 4 ; SIZE ; @@ -878,10 +851,9 @@ let%expect_test _ = PAIR ; DIP { DUP } ; SWAP ; - CAR ; DIP { DUP } ; - PAIR ; - DIP { DROP } } + SWAP ; + DIP { DROP 2 } } { DUP ; DIP 2 { DUP } ; DIG 2 ; @@ -898,47 +870,15 @@ let%expect_test _ = SWAP ; PAIR ; PAIR ; - SWAP ; - CAR ; - PAIR } ; + DIP { DROP } } ; DIP 7 { DUP } ; DIG 7 ; DIP 3 { DUP } ; DIG 3 ; + DIP { DROP ; DUP } ; SWAP ; - CAR ; - PAIR ; - DIP { DUP } ; - SWAP ; - CAR ; - CDR ; - SWAP ; - CDR ; - SWAP ; - PAIR ; - DIP { DUP } ; - SWAP ; - CDR ; - SWAP ; - CAR ; - PAIR ; - DIP { DUP } ; - SWAP ; - CAR ; - CDR ; - SWAP ; - CDR ; - SWAP ; - PAIR ; - DIP { DUP } ; - SWAP ; - CDR ; - SWAP ; - CAR ; - PAIR ; - DIP { DROP 7 } } ; + DIP { DROP 8 } } ; DUP ; - CDR ; NIL operation ; PAIR ; DIP { DROP 6 } } ; @@ -1174,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#654 = #P in let p = rhs#654.0 in let s = rhs#654.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#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"} If you're not sure how to fix this error, you can @@ -1187,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#657 = #P in let p = rhs#657.0 in let s = rhs#657.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#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"} If you're not sure how to fix this error, you can diff --git a/src/passes/2-concrete_to_imperative/dune b/src/passes/2-concrete_to_imperative/dune index c3f316ce4..1aa60f304 100644 --- a/src/passes/2-concrete_to_imperative/dune +++ b/src/passes/2-concrete_to_imperative/dune @@ -6,7 +6,6 @@ tezos-utils parser ast_imperative - self_ast_imperative operators) (modules cameligo pascaligo concrete_to_imperative) (preprocess diff --git a/src/passes/2-concrete_to_imperative/pascaligo.ml b/src/passes/2-concrete_to_imperative/pascaligo.ml index 7823cfb4e..53287557d 100644 --- a/src/passes/2-concrete_to_imperative/pascaligo.ml +++ b/src/passes/2-concrete_to_imperative/pascaligo.ml @@ -14,90 +14,6 @@ let pseq_to_list = function | Some lst -> npseq_to_list lst let get_value : 'a Raw.reg -> 'a = fun x -> x.value -and repair_mutable_variable_in_matching (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = - let%bind captured_names = Self_ast_imperative.fold_map_expression - (* TODO : these should use Variables sets *) - (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> - match ass_exp.expression_content with - | E_let_in {let_binder;mut=false;rhs;let_result} -> - let (name,_) = let_binder in - ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result) - | E_let_in {let_binder;mut=true; rhs;let_result} -> - let (name,_) = let_binder in - if List.mem name decl_var then - ok (true,(decl_var, free_var), 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 = e_let_in (env,None) false false (e_update (e_variable env) (Var.to_name name) (e_variable name)) let_result in - ok (true,(decl_var, free_var), e_let_in let_binder false false rhs expr) - ) - | E_variable name -> - if List.mem name decl_var || List.mem name free_var || Var.equal name env then - ok (true,(decl_var, free_var), e_variable name) - else - ok (true, (decl_var, name::free_var), e_variable name) - | E_constant {cons_name=C_MAP_FOLD;arguments= _} - | E_constant {cons_name=C_SET_FOLD;arguments= _} - | E_constant {cons_name=C_LIST_FOLD;arguments= _} - | E_matching _ -> ok @@ (false, (decl_var,free_var),ass_exp) - | _ -> ok (true, (decl_var, free_var),ass_exp) - ) - (element_names,[]) - for_body in - ok @@ captured_names - -and repair_mutable_variable_in_loops (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = - let%bind captured_names = Self_ast_imperative.fold_map_expression - (* TODO : these should use Variables sets *) - (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> - match ass_exp.expression_content with - | E_let_in {let_binder;mut=false;rhs;let_result} -> - let (name,_) = let_binder in - ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result) - | E_let_in {let_binder;mut=true; rhs;let_result} -> - let (name,_) = let_binder in - if List.mem name decl_var then - ok (true,(decl_var, free_var), 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 = e_let_in (env,None) false false ( - e_update (e_variable env) ("0") - (e_update (e_accessor (e_variable env) "0") (Var.to_name name) (e_variable name)) - ) - let_result in - ok (true,(decl_var, free_var), e_let_in let_binder false false rhs expr) - ) - | E_variable name -> - if List.mem name decl_var || List.mem name free_var || Var.equal name env then - ok (true,(decl_var, free_var), e_variable name) - else - ok (true,(decl_var, name::free_var), e_variable name) - | E_constant {cons_name=C_MAP_FOLD;arguments= _} - | E_constant {cons_name=C_SET_FOLD;arguments= _} - | E_constant {cons_name=C_LIST_FOLD;arguments= _} - | E_matching _ -> ok @@ (false,(decl_var,free_var),ass_exp) - | _ -> ok (true,(decl_var, free_var),ass_exp) - ) - (element_names,[]) - for_body in - ok @@ captured_names - -and store_mutable_variable (free_vars : expression_variable list) = - if (List.length free_vars == 0) then - e_unit () - else - let aux var = (Var.to_name var, e_variable var) in - e_record_ez (List.map aux free_vars) - -and restore_mutable_variable (expr : expression->expression) (free_vars : expression_variable list) (env :expression_variable) = - let aux (f:expression -> expression) (ev:expression_variable) = - ok @@ fun expr -> f (e_let_in (ev,None) true false (e_accessor (e_variable env) (Var.to_name ev)) expr) - in - let%bind ef = bind_fold_list aux (fun e -> e) free_vars in - ok @@ fun expr'_opt -> match expr'_opt with - | None -> ok @@ expr (ef (e_skip ())) - | Some expr' -> ok @@ expr (ef expr') - module Errors = struct @@ -433,10 +349,7 @@ let rec compile_expression (t:Raw.expr) : expr result = let%bind expr = compile_expression c.test in let%bind match_true = compile_expression c.ifso in let%bind match_false = compile_expression c.ifnot in - let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in - let env = Var.fresh () in - let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in - return @@ match_expr + return @@ e_matching expr ~loc (Match_bool {match_true; match_false}) | ECase c -> ( let (c , loc) = r_split c in @@ -450,10 +363,7 @@ let rec compile_expression (t:Raw.expr) : expr result = @@ List.map get_value @@ npseq_to_list c.cases.value in let%bind cases = compile_cases lst in - let match_expr = e_matching ~loc e cases in - let env = Var.fresh () in - let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in - return @@ match_expr + return @@ e_matching ~loc e cases ) | EMap (MapInj mi) -> ( let (mi , loc) = r_split mi in @@ -819,35 +729,6 @@ and compile_statement_list statements = hook (compile_data_declaration d :: acc) statements in bind_list @@ hook [] (List.rev statements) -and get_case_variables (t:Raw.pattern) : expression_variable list result = - match t with - | PConstr PFalse _ - | PConstr PTrue _ - | PConstr PNone _ -> ok @@ [] - | PConstr PSomeApp v -> (let (_,v) = v.value in get_case_variables (v.value.inside)) - | PConstr PConstrApp v -> ( - match v.value with - | constr, None -> ok @@ [ Var.of_name constr.value] - | constr, pat_opt -> - let%bind pat = - trace_option (unsupported_cst_constr t) @@ - pat_opt in - let pat = npseq_to_list pat.value.inside in - let%bind var = bind_map_list get_case_variables pat in - ok @@ [Var.of_name constr.value ] @ (List.concat var) - ) - | PList PNil _ -> ok @@ [] - | PList PCons c -> ( - match c.value with - | a, [(_, b)] -> - let%bind a = get_case_variables a in - let%bind b = get_case_variables b in - ok @@ a@b - | _ -> fail @@ unsupported_deep_list_patterns c - ) - | PVar v -> ok @@ [Var.of_name v.value] - | p -> fail @@ unsupported_cst_constr p - and compile_single_instruction : Raw.instruction -> (_ -> expression result) result = fun t -> match t with @@ -877,14 +758,33 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res return_statement @@ e_skip ~loc () ) | Loop (While l) -> - compile_while_loop l.value + let (wl, loc) = r_split l in + let%bind condition = compile_expression wl.cond in + let%bind body = compile_block wl.block.value in + let%bind body = body @@ None in + return_statement @@ e_while ~loc condition body | Loop (For (ForInt fi)) -> ( - let%bind loop = compile_for_int fi.value in - ok loop + let (fi,loc) = r_split fi in + let binder = Var.of_name fi.assign.value.name.value in + let%bind start = compile_expression fi.assign.value.expr in + let%bind bound = compile_expression fi.bound in + let increment = e_int 1 in + let%bind body = compile_block fi.block.value in + let%bind body = body @@ None in + return_statement @@ e_for ~loc binder start bound increment body ) | Loop (For (ForCollect fc)) -> - let%bind loop = compile_for_collect fc.value in - ok loop + let (fc,loc) = r_split fc in + let binder = (Var.of_name fc.var.value, Option.map (fun x -> Var.of_name (snd x:string Raw.reg).value) fc.bind_to) in + let%bind collection = compile_expression fc.expr in + let collection_type = match fc.collection with + | Map _ -> Map + | Set _ -> Set + | List _ -> List + in + let%bind body = compile_block fc.block.value in + let%bind body = body @@ None in + return_statement @@ e_for_each ~loc binder collection collection_type body | Cond c -> ( let (c , loc) = r_split c in let%bind expr = compile_expression c.test in @@ -906,26 +806,10 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res compile_block value | ShortBlock {value; _} -> compile_statements @@ fst value.inside in - let env = Var.fresh () in - let%bind match_true' = match_true None in - let%bind match_false' = match_false None in - let%bind match_true = match_true @@ Some (e_variable env) in - let%bind match_false = match_false @@ Some (e_variable env) in - - let%bind ((_,free_vars_true), match_true) = repair_mutable_variable_in_matching match_true [] env in - let%bind ((_,free_vars_false), match_false) = repair_mutable_variable_in_matching match_false [] env in - let free_vars = free_vars_true @ free_vars_false in - if (List.length free_vars != 0) then - let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in - let return_expr = fun expr -> - e_let_in (env,None) false false (store_mutable_variable free_vars) @@ - e_let_in (env,None) false false match_expr @@ - expr - in - restore_mutable_variable return_expr free_vars env - else - return_statement @@ e_matching expr ~loc (Match_bool {match_true=match_true'; match_false=match_false'}) + let%bind match_true = match_true None in + let%bind match_false = match_false None in + return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false}) ) | Assign a -> ( let (a , loc) = r_split a in @@ -954,9 +838,8 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res | CaseInstr c -> ( let (c , loc) = r_split c in let%bind expr = compile_expression c.expr in - let env = Var.fresh () in - let%bind (fv,cases) = - let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) = + let%bind cases = + let aux (x : Raw.if_clause Raw.case_clause Raw.reg) = let%bind case_clause = match x.value.rhs with ClauseInstr i -> @@ -967,28 +850,13 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res compile_block value | ShortBlock {value; _} -> compile_statements @@ fst value.inside in - let%bind case_clause'= case_clause @@ None in - let%bind case_clause = case_clause @@ Some(e_variable env) in - let%bind case_vars = get_case_variables x.value.pattern in - let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching case_clause case_vars env in - ok (free_vars::fv,(x.value.pattern, case_clause, case_clause')) in - bind_fold_map_list aux [] (npseq_to_list c.cases.value) in - let free_vars = List.concat fv in - if (List.length free_vars == 0) then ( - let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in - let%bind m = compile_cases cases in - return_statement @@ e_matching ~loc expr m - ) else ( - let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in - let%bind m = compile_cases cases in - let match_expr = e_matching ~loc expr m in - let return_expr = fun expr -> - e_let_in (env,None) false false (store_mutable_variable free_vars) @@ - e_let_in (env,None) false false match_expr @@ - expr - in - restore_mutable_variable return_expr free_vars env - ) + let%bind case_clause = case_clause None in + ok (x.value.pattern, case_clause) in + bind_list + @@ List.map aux + @@ npseq_to_list c.cases.value in + let%bind m = compile_cases cases in + return_statement @@ e_matching ~loc expr m ) | RecordPatch r -> ( let reg = r.region in @@ -1204,121 +1072,6 @@ and compile_statements : Raw.statements -> (_ -> expression result) result = and compile_block : Raw.block -> (_ -> expression result) result = fun t -> compile_statements t.statements -and compile_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl -> - let env_rec = Var.fresh () in - let binder = Var.fresh () in - - let%bind cond = compile_expression wl.cond in - let ctrl = - (e_variable binder) - in - - let%bind for_body = compile_block wl.block.value in - let%bind for_body = for_body @@ Some( ctrl ) in - let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in - - let aux name expr= - e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr - in - let init_rec = e_tuple [store_mutable_variable @@ captured_name_list] in - let restore = fun expr -> List.fold_right aux captured_name_list expr in - let continue_expr = e_constant C_FOLD_CONTINUE [for_body] in - let stop_expr = e_constant C_FOLD_STOP [e_variable binder] in - let aux_func = - e_lambda binder None None @@ - restore @@ - e_cond cond continue_expr stop_expr in - let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in - let return_expr = fun expr -> - e_let_in (env_rec,None) false false init_rec @@ - e_let_in (env_rec,None) false false loop @@ - e_let_in (env_rec,None) false false (e_accessor (e_variable env_rec) "0") @@ - expr - in - restore_mutable_variable return_expr captured_name_list env_rec - - -and compile_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> - let env_rec = Var.fresh () in - let binder = Var.fresh () in - let name = fi.assign.value.name.value in - let it = Var.of_name name in - let var = e_variable it in - (*Make the cond and the step *) - let%bind value = compile_expression fi.assign.value.expr in - let%bind bound = compile_expression fi.bound in - let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in - let step = e_int 1 in - let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in - let ctrl = - e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ]) @@ - e_let_in (binder, None) false false (e_update (e_variable binder) "1" var)@@ - continue_expr - in - (* Modify the body loop*) - let%bind for_body = compile_block fi.block.value in - let%bind for_body = for_body @@ Some ctrl in - let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder in - - let aux name expr= - e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr - in - - (* restores the initial value of the free_var*) - let restore = fun expr -> List.fold_right aux captured_name_list expr in - - (*Prep the lambda for the fold*) - let stop_expr = e_constant C_FOLD_STOP [e_variable binder] in - let aux_func = e_lambda binder None None @@ - e_let_in (it,Some t_int) false false (e_accessor (e_variable binder) "1") @@ - e_cond cond (restore for_body) (stop_expr) in - - (* Make the fold_while en precharge the vakye *) - let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in - let init_rec = e_pair (store_mutable_variable @@ captured_name_list) var in - - let return_expr = fun expr -> - e_let_in (it, Some t_int) false false value @@ - e_let_in (env_rec,None) false false init_rec @@ - e_let_in (env_rec,None) false false loop @@ - e_let_in (env_rec,None) false false (e_accessor (e_variable env_rec) "0") @@ - expr - in - restore_mutable_variable return_expr captured_name_list env_rec - -and compile_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> - let binder = Var.of_name "arguments" in - let%bind element_names = ok @@ match fc.bind_to with - | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value] - | None -> [Var.of_name fc.var.value] in - - let env = Var.fresh () in - let%bind for_body = compile_block fc.block.value in - let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in - let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in - - let init_record = store_mutable_variable free_vars in - let%bind collect = compile_expression fc.expr in - let aux name expr= - e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr - in - let restore = fun expr -> List.fold_right aux free_vars expr in - let restore = match fc.collection with - | Map _ -> (match fc.bind_to with - | Some v -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") - (e_let_in (Var.of_name (snd v).value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "1") expr)) - | None -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") expr) - ) - | _ -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_variable binder) "1") expr) - in - let lambda = e_lambda binder None None (restore for_body) in - let op_name = match fc.collection with - | Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in - let fold = fun expr -> - e_let_in (env,None) false false (e_constant op_name [lambda; collect ; init_record]) @@ - expr - in - restore_mutable_variable fold free_vars env and compile_declaration_list declarations : declaration Location.wrap list result = let open Raw in diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index fc15f29e1..42ee86259 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -63,6 +63,17 @@ 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_for {body; _} -> + let%bind res = self init' body in + ok res + | E_for_each {collection; body; _} -> + let%bind res = self init' collection in + let%bind res = self res body in + ok res + | E_while {condition; body} -> + 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 -> @@ -176,6 +187,18 @@ 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_for {binder; start; final; increment; body} -> + let%bind body = self body in + return @@ E_for {binder; start; final; increment; body} + | E_for_each {binder; collection; collection_type; body} -> + let%bind collection = self collection in + let%bind body = self body in + return @@ E_for_each {binder; collection; collection_type; body} + | E_while {condition; body} -> + let%bind condition = self condition in + let%bind body = self body in + return @@ E_while {condition; body} + | E_literal _ | E_variable _ | E_skip as e' -> return e' and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> @@ -323,6 +346,17 @@ 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_for {binder; start; final; increment; body} -> + let%bind (res, body) = self init' body in + ok (res, return @@ E_for {binder; start; final; increment; body}) + | E_for_each {binder; collection; collection_type; body} -> + let%bind res,collection = self init' collection in + let%bind res,body = self res body in + ok (res, return @@ E_for_each {binder; collection; collection_type; body}) + | E_while {condition; body} -> + let%bind res,condition = self init' condition in + let%bind res,body = self res body in + ok (res, return @@ E_while {condition; body}) | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e') and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> diff --git a/src/passes/4-imperative_to_sugar/dune b/src/passes/4-imperative_to_sugar/dune index 445998b90..66f996558 100644 --- a/src/passes/4-imperative_to_sugar/dune +++ b/src/passes/4-imperative_to_sugar/dune @@ -5,6 +5,7 @@ simple-utils ast_imperative ast_sugar + self_ast_sugar proto-alpha-utils ) (preprocess 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 9cdfed78e..a461dc9ae 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -2,6 +2,105 @@ module I = Ast_imperative module O = Ast_sugar open Trace +module Errors = struct + let bad_collection expr = + let title () = "" in + let message () = Format.asprintf "\nCannot loop over this collection : %a\n" I.PP.expression expr in + let data = [ + ("location", + fun () -> Format.asprintf "%a" Location.pp expr.location) + ] in + error ~data title message +end + +let rec add_to_end (expression: O.expression) to_add = + match expression.expression_content with + | O.E_let_in lt -> + let lt = {lt with let_result = add_to_end lt.let_result to_add} in + {expression with expression_content = O.E_let_in lt} + | O.E_sequence seq -> + let seq = {seq with expr2 = add_to_end seq.expr2 to_add} in + {expression with expression_content = O.E_sequence seq} + | _ -> O.e_sequence expression to_add + +let repair_mutable_variable_in_matching (match_body : O.expression) (element_names : O.expression_variable list) (env : I.expression_variable) = + let%bind ((dv,fv),mb) = Self_ast_sugar.fold_map_expression + (* TODO : these should use Variables sets *) + (fun (decl_var,free_var : O.expression_variable list * O.expression_variable list) (ass_exp : O.expression) -> + match ass_exp.expression_content with + | E_let_in {let_binder;mut=false;rhs;let_result} -> + let (name,_) = let_binder in + ok (true,(name::decl_var, free_var),O.e_let_in let_binder false false rhs let_result) + | E_let_in {let_binder;mut=true; rhs;let_result} -> + let (name,_) = let_binder in + if List.mem name decl_var then + 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 + ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr) + ) + | E_constant {cons_name=C_MAP_FOLD;arguments= _} + | E_constant {cons_name=C_SET_FOLD;arguments= _} + | E_constant {cons_name=C_LIST_FOLD;arguments= _} + | E_matching _ -> ok @@ (false, (decl_var,free_var),ass_exp) + | _ -> ok (true, (decl_var, free_var),ass_exp) + ) + (element_names,[]) + match_body in + ok @@ ((dv,fv),mb) + +and repair_mutable_variable_in_loops (for_body : O.expression) (element_names : O.expression_variable list) (env : O.expression_variable) = + let%bind ((dv,fv),fb) = Self_ast_sugar.fold_map_expression + (* TODO : these should use Variables sets *) + (fun (decl_var,free_var : O.expression_variable list * O.expression_variable list) (ass_exp : O.expression) -> + (* Format.printf "debug: dv:%a; fv:%a; expr:%a \n%!" + (I.PP.list_sep_d I.PP.expression_variable) decl_var + (I.PP.list_sep_d I.PP.expression_variable) decl_var + O.PP.expression ass_exp + ;*) + match ass_exp.expression_content with + | E_let_in {let_binder;mut=false;} -> + let (name,_) = let_binder in + ok (true,(name::decl_var, free_var),ass_exp) + | E_let_in {let_binder;mut=true; rhs;let_result} -> + let (name,_) = let_binder in + if List.mem name decl_var then + 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) ("0") + (O.e_update (O.e_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) + ) + | E_constant {cons_name=C_MAP_FOLD;arguments= _} + | E_constant {cons_name=C_SET_FOLD;arguments= _} + | E_constant {cons_name=C_LIST_FOLD;arguments= _} + | E_matching _ -> ok @@ (false,(decl_var,free_var),ass_exp) + | _ -> ok (true,(decl_var, free_var),ass_exp) + ) + (element_names,[]) + for_body in + ok @@ ((dv,fv),fb) + +and store_mutable_variable (free_vars : I.expression_variable list) = + if (List.length free_vars == 0) then + O.e_unit () + else + let aux var = (Var.to_name var, O.e_variable var) in + O.e_record_ez (List.map aux free_vars) + +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) + in + let ef = List.fold_left aux (fun e -> e) free_vars in + expr (ef (O.e_skip ())) + + let rec compile_type_expression : I.type_expression -> O.type_expression result = fun te -> let return te = ok @@ O.make_t te in @@ -79,19 +178,18 @@ 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;mut;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);inline;rhs;let_result} + return @@ O.E_let_in {let_binder=(binder,ty_opt);mut;inline;rhs;let_result} | I.E_constructor {constructor;element} -> let%bind element = compile_expression element in return @@ O.E_constructor {constructor;element} - | I.E_matching {matchee; cases} -> - let%bind matchee = compile_expression matchee in - let%bind cases = compile_matching cases in - return @@ O.E_matching {matchee;cases} + | I.E_matching m -> + let%bind m = compile_matching m in + return @@ m | I.E_record record -> let record = I.LMap.to_kv_list record in let%bind record = @@ -136,43 +234,237 @@ let rec compile_expression : I.expression -> O.expression result = | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in - return @@ O.E_sequence {expr1; expr2} + ok @@ add_to_end expr1 expr2 | I.E_skip -> return @@ O.E_skip + | I.E_for f -> + let%bind f = compile_for f in + return @@ f + | I.E_for_each fe -> + let%bind fe = compile_for_each fe in + return @@ fe + | I.E_while w -> + let%bind w = compile_while w in + return @@ w + 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 let%bind output_type = bind_map_option compile_type_expression output_type in let%bind result = compile_expression result in ok @@ O.{binder;input_type;output_type;result} -and compile_matching : I.matching_expr -> O.matching_expr result = - fun m -> - match m with + +and compile_matching : I.matching -> O.expression_content result = + fun {matchee;cases} -> + let%bind matchee = compile_expression matchee in + match cases with | I.Match_bool {match_true;match_false} -> - let%bind match_true = compile_expression match_true in - let%bind match_false = compile_expression match_false in - ok @@ O.Match_bool {match_true;match_false} - | I.Match_list {match_nil;match_cons} -> - let%bind match_nil = compile_expression match_nil in - let (hd,tl,expr,tv) = match_cons in - let%bind expr = compile_expression expr in - ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} + let%bind match_true' = compile_expression match_true in + let%bind match_false' = compile_expression match_false in + let env = Var.fresh () in + let%bind ((_,free_vars_true), match_true) = repair_mutable_variable_in_matching match_true' [] env in + let%bind ((_,free_vars_false), match_false) = repair_mutable_variable_in_matching match_false' [] env in + let match_true = add_to_end match_true (O.e_variable env) in + let match_false = add_to_end match_false (O.e_variable env) in + + let free_vars = List.sort_uniq Var.compare @@ free_vars_true @ free_vars_false in + if (List.length free_vars != 0) then + let match_expr = O.e_matching matchee (O.Match_bool {match_true; match_false}) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false match_expr @@ + expr + } + in + ok @@ restore_mutable_variable return_expr free_vars env + else + ok @@ O.E_matching {matchee;cases=O.Match_bool {match_true=match_true';match_false=match_false'}} | I.Match_option {match_none;match_some} -> - let%bind match_none = compile_expression match_none in + let%bind match_none' = compile_expression match_none in let (n,expr,tv) = match_some in - let%bind expr = compile_expression expr in - ok @@ O.Match_option {match_none; match_some=(n,expr,tv)} + let%bind expr' = compile_expression expr in + let env = Var.fresh () in + let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in + let%bind ((_,free_vars_some), expr) = repair_mutable_variable_in_matching expr' [n] env in + let match_none = add_to_end match_none (O.e_variable env) in + let expr = add_to_end expr (O.e_variable env) in + let free_vars = List.sort_uniq Var.compare @@ free_vars_none @ free_vars_some in + if (List.length free_vars != 0) then + let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr,tv)}) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false match_expr @@ + expr + } + in + ok @@ restore_mutable_variable return_expr free_vars env + else + ok @@ O.E_matching {matchee; cases=O.Match_option {match_none=match_none'; match_some=(n,expr',tv)}} + | I.Match_list {match_nil;match_cons} -> + let%bind match_nil' = compile_expression match_nil in + let (hd,tl,expr,tv) = match_cons in + let%bind expr' = compile_expression expr in + let env = Var.fresh () in + let%bind ((_,free_vars_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env in + let%bind ((_,free_vars_cons), expr) = repair_mutable_variable_in_matching expr' [hd;tl] env in + let match_nil = add_to_end match_nil (O.e_variable env) in + let expr = add_to_end expr (O.e_variable env) in + let free_vars = List.sort_uniq Var.compare @@ free_vars_nil @ free_vars_cons in + if (List.length free_vars != 0) then + let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false match_expr @@ + expr + } + in + ok @@ restore_mutable_variable return_expr free_vars env + else + ok @@ O.E_matching {matchee;cases=O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)}} | I.Match_tuple ((lst,expr), tv) -> let%bind expr = compile_expression expr in - ok @@ O.Match_tuple ((lst,expr), tv) + ok @@ O.E_matching {matchee; cases=O.Match_tuple ((lst,expr), tv)} | I.Match_variant (lst,tv) -> - let%bind lst = bind_map_list ( - fun ((c,n),expr) -> - let%bind expr = compile_expression expr in - ok @@ ((c,n),expr) - ) lst - in - ok @@ O.Match_variant (lst,tv) + let env = Var.fresh () in + let aux fv ((c,n),expr) = + let%bind expr = compile_expression expr in + let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching expr [n] env in + let case_clause'= expr in + let case_clause = add_to_end case_clause (O.e_variable env) in + ok (free_vars::fv,((c,n), case_clause, case_clause')) in + let%bind (fv,cases) = bind_fold_map_list aux [] lst in + let free_vars = List.sort_uniq Var.compare @@ List.concat fv in + if (List.length free_vars == 0) then ( + let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in + ok @@ O.E_matching{matchee; cases=O.Match_variant (cases,tv)} + ) else ( + let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in + let match_expr = O.e_matching matchee @@ O.Match_variant (cases,tv) in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false; rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false match_expr @@ + expr + } + in + ok @@ restore_mutable_variable return_expr free_vars env + ) +and compile_while I.{condition;body} = + let env_rec = Var.fresh () in + let binder = Var.fresh () in + + let%bind cond = compile_expression condition in + let ctrl = + (O.e_variable binder) + in + + let%bind for_body = compile_expression body in + let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in + 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 + 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 + let continue_expr = O.e_constant C_FOLD_CONTINUE [for_body] in + let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable binder] in + let aux_func = + O.e_lambda binder None None @@ + restore @@ + O.e_cond cond continue_expr stop_expr in + let loop = O.e_constant C_FOLD_WHILE [aux_func; O.e_variable env_rec] in + let let_binder = (env_rec,None) in + 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") @@ + expr + } + in + ok @@ restore_mutable_variable return_expr captured_name_list env_rec + + +and compile_for I.{binder;start;final;increment;body} = + let env_rec = Var.fresh () in + (*Make the cond and the step *) + let cond = I.e_annotation (I.e_constant C_LE [I.e_variable binder ; final]) I.t_bool in + let%bind cond = compile_expression cond in + let%bind step = compile_expression increment in + 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)@@ + continue_expr + in + (* Modify the body loop*) + let%bind body = compile_expression body in + let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops body [binder] env_rec in + 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 + in + + (* restores the initial value of the free_var*) + let restore = fun expr -> List.fold_right aux captured_name_list expr in + + (*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_cond cond (restore for_body) (stop_expr) in + + (* Make the fold_while en precharge the vakye *) + let loop = O.e_constant C_FOLD_WHILE [aux_func; O.e_variable env_rec] in + let init_rec = O.e_pair (store_mutable_variable captured_name_list) @@ O.e_variable binder in + + let%bind start = compile_expression start in + let let_binder = (env_rec,None) in + let return_expr = fun expr -> + 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") @@ + expr + } + in + ok @@ restore_mutable_variable return_expr captured_name_list env_rec + +and compile_for_each I.{binder;collection;collection_type; body} = + let args = Var.fresh () in + let%bind element_names = ok @@ match snd binder with + | Some v -> [fst binder;v] + | None -> [fst binder] + in + + 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 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 + 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) + ) + | _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_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 + | Map -> ok @@ O.C_MAP_FOLD | Set -> ok @@ O.C_SET_FOLD | List -> ok @@ O.C_LIST_FOLD + in + let fold = fun expr -> + O.E_let_in {let_binder=(env,None);mut=false; inline=false;rhs=(O.e_constant op_name [lambda; collect ; init_record]); + let_result=expr;} + in + ok @@ restore_mutable_variable fold free_vars env let compile_declaration : I.declaration Location.wrap -> _ = fun {wrap_content=declaration;location} -> let return decl = ok @@ Location.wrap ~loc:location decl in diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml new file mode 100644 index 000000000..71597ce5e --- /dev/null +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -0,0 +1,356 @@ +open Ast_sugar +open Trace +open Stage_common.Helpers + +type 'a folder = 'a -> expression -> 'a result +let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> + let self = fold_expression f in + let%bind init' = f init e in + match e.expression_content with + | E_literal _ | E_variable _ | E_skip -> ok init' + | E_list lst | E_set lst | E_constant {arguments=lst} -> ( + let%bind res = bind_fold_list self init' lst in + ok res + ) + | E_map lst | E_big_map lst -> ( + let%bind res = bind_fold_list (bind_fold_pair self) init' lst in + ok res + ) + | E_look_up ab -> + let%bind res = bind_fold_pair self init' ab in + ok res + | E_application {lamb;args} -> ( + let ab = (lamb,args) in + let%bind res = bind_fold_pair self init' ab in + ok res + ) + | E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e } + | E_ascription {anno_expr=e; _} | E_constructor {element=e} -> ( + let%bind res = self init' e in + ok res + ) + | E_matching {matchee=e; cases} -> ( + let%bind res = self init' e in + let%bind res = fold_cases f res cases in + ok res + ) + | E_record m -> ( + let aux init'' _ expr = + let%bind res = fold_expression self init'' expr in + ok res + in + let%bind res = bind_fold_lmap aux (ok init') m in + ok res + ) + | E_record_update {record;update} -> ( + let%bind res = self init' record in + let%bind res = fold_expression self res update in + ok res + ) + | E_record_accessor {expr} -> ( + let%bind res = self init' expr in + ok res + ) + | E_let_in { let_binder = _ ; rhs ; let_result } -> ( + let%bind res = self init' rhs in + let%bind res = self res let_result in + ok res + ) + | E_recursive { lambda={result=e;_}; _} -> + let%bind res = self init' e in + ok res + | E_sequence {expr1;expr2} -> + let ab = (expr1,expr2) in + let%bind res = bind_fold_pair self init' ab in + 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 } -> ( + let%bind res = fold_expression f init match_true in + let%bind res = fold_expression f res match_false in + ok res + ) + | Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> ( + let%bind res = fold_expression f init match_nil in + let%bind res = fold_expression f res cons in + ok res + ) + | Match_option { match_none ; match_some = (_ , some, _) } -> ( + let%bind res = fold_expression f init match_none in + let%bind res = fold_expression f res some in + ok res + ) + | Match_tuple ((_ , e), _) -> ( + let%bind res = fold_expression f init e in + ok res + ) + | Match_variant (lst, _) -> ( + let aux init' ((_ , _) , e) = + let%bind res' = fold_expression f init' e in + ok res' in + let%bind res = bind_fold_list aux init lst in + ok res + ) + +type exp_mapper = expression -> expression result +type ty_exp_mapper = type_expression -> type_expression result +type abs_mapper = + | Expression of exp_mapper + | Type_expression of ty_exp_mapper +let rec map_expression : exp_mapper -> expression -> expression result = fun f e -> + let self = map_expression f in + let%bind e' = f e in + let return expression_content = ok { e' with expression_content } in + match e'.expression_content with + | E_list lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_list lst' + ) + | E_set lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_set lst' + ) + | E_map lst -> ( + let%bind lst' = bind_map_list (bind_map_pair self) lst in + return @@ E_map lst' + ) + | E_big_map lst -> ( + let%bind lst' = bind_map_list (bind_map_pair self) lst in + return @@ E_big_map lst' + ) + | E_look_up ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_look_up ab' + ) + | E_ascription ascr -> ( + let%bind e' = self ascr.anno_expr in + return @@ E_ascription {ascr with anno_expr=e'} + ) + | E_matching {matchee=e;cases} -> ( + let%bind e' = self e in + let%bind cases' = map_cases f cases in + 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'} + ) + | E_record m -> ( + let%bind m' = bind_map_lmap self m in + return @@ E_record m' + ) + | E_record_update {record; path; update} -> ( + let%bind record = self record in + let%bind update = self update in + return @@ E_record_update {record;path;update} + ) + | E_constructor c -> ( + let%bind e' = self c.element in + return @@ E_constructor {c with element = e'} + ) + | E_application {lamb;args} -> ( + let ab = (lamb,args) in + 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 } -> ( + 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 } + ) + | E_lambda { binder ; input_type ; output_type ; result } -> ( + let%bind result = self result in + return @@ E_lambda { binder ; input_type ; output_type ; result } + ) + | E_recursive { fun_name; fun_type; lambda} -> + let%bind result = self lambda.result in + let lambda = {lambda with result} in + return @@ E_recursive { fun_name; fun_type; lambda} + | E_constant c -> ( + let%bind args = bind_map_list self c.arguments in + return @@ E_constant {c with arguments=args} + ) + | E_sequence {expr1;expr2} -> ( + let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in + return @@ E_sequence {expr1;expr2} + ) + | E_literal _ | E_variable _ | E_skip as e' -> return e' + +and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> + let self = map_type_expression f in + let%bind te' = f te in + let return type_content = ok { te' with type_content } in + match te'.type_content with + | T_sum temap -> + let%bind temap' = bind_map_cmap self temap in + return @@ (T_sum temap') + | T_record temap -> + let%bind temap' = bind_map_lmap self temap in + return @@ (T_record temap') + | T_arrow {type1 ; type2} -> + let%bind type1' = self type1 in + let%bind type2' = self type2 in + return @@ (T_arrow {type1=type1' ; type2=type2'}) + | T_operator _ + | T_variable _ | T_constant _ -> ok te' + +and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind match_true = map_expression f match_true in + let%bind match_false = map_expression f match_false in + ok @@ Match_bool { match_true ; match_false } + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( + let%bind match_nil = map_expression f match_nil in + let%bind cons = map_expression f cons in + ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) } + ) + | Match_option { match_none ; match_some = (name , some, _) } -> ( + let%bind match_none = map_expression f match_none in + let%bind some = map_expression f some in + ok @@ Match_option { match_none ; match_some = (name , some, ()) } + ) + | Match_tuple ((names , e), _) -> ( + let%bind e' = map_expression f e in + ok @@ Match_tuple ((names , e'), []) + ) + | Match_variant (lst, _) -> ( + let aux ((a , b) , e) = + let%bind e' = map_expression f e in + ok ((a , b) , e') + in + let%bind lst' = bind_map_list aux lst in + ok @@ Match_variant (lst', ()) + ) + +and map_program : abs_mapper -> program -> program result = fun m p -> + let aux = fun (x : declaration) -> + match x,m with + | (Declaration_constant (t , o , i, e), Expression m') -> ( + let%bind e' = map_expression m' e in + ok (Declaration_constant (t , o , i, e')) + ) + | (Declaration_type (tv,te), Type_expression m') -> ( + let%bind te' = map_type_expression m' te in + ok (Declaration_type (tv, te')) + ) + | decl,_ -> ok decl + (* | Declaration_type of (type_variable * type_expression) *) + in + bind_map_list (bind_map_location aux) p + +type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result +let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e -> + let self = fold_map_expression f in + let%bind (continue, init',e') = f a e in + if (not continue) then ok(init',e') + else + let return expression_content = { e' with expression_content } in + match e'.expression_content with + | E_list lst -> ( + let%bind (res, lst') = bind_fold_map_list self init' lst in + ok (res, return @@ E_list lst') + ) + | E_set lst -> ( + let%bind (res, lst') = bind_fold_map_list self init' lst in + ok (res, return @@ E_set lst') + ) + | E_map lst -> ( + let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in + ok (res, return @@ E_map lst') + ) + | E_big_map lst -> ( + let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in + ok (res, return @@ E_big_map lst') + ) + | E_look_up ab -> ( + let%bind (res, ab') = bind_fold_map_pair self init' ab in + ok (res, return @@ E_look_up ab') + ) + | E_ascription ascr -> ( + let%bind (res,e') = self init' ascr.anno_expr in + ok (res, return @@ E_ascription {ascr with anno_expr=e'}) + ) + | E_matching {matchee=e;cases} -> ( + let%bind (res, e') = self init' e in + let%bind (res,cases') = fold_map_cases f res cases in + 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'}) + ) + | 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 + let m' = LMap.of_list lst' in + ok (res, return @@ E_record m') + ) + | E_record_update {record; path; update} -> ( + let%bind (res, record) = self init' record in + let%bind (res, update) = self res update in + ok (res, return @@ E_record_update {record;path;update}) + ) + | E_constructor c -> ( + let%bind (res,e') = self init' c.element in + ok (res, return @@ E_constructor {c with element = e'}) + ) + | E_application {lamb;args} -> ( + let ab = (lamb,args) in + 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 } -> ( + 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 }) + ) + | E_lambda { binder ; input_type ; output_type ; result } -> ( + let%bind (res,result) = self init' result in + ok ( res, return @@ E_lambda { binder ; input_type ; output_type ; result }) + ) + | E_recursive { fun_name; fun_type; lambda} -> + let%bind (res, result) = self init' lambda.result in + let lambda = {lambda with result} in + ok ( res, return @@ E_recursive { fun_name; fun_type; lambda}) + | E_constant c -> ( + let%bind (res,args) = bind_fold_map_list self init' c.arguments in + ok (res, return @@ E_constant {c with arguments=args}) + ) + | E_sequence {expr1;expr2} -> ( + let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in + ok (res, return @@ E_sequence {expr1;expr2}) + ) + | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e') + +and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind (init, match_true) = fold_map_expression f init match_true in + let%bind (init, match_false) = fold_map_expression f init match_false in + ok @@ (init, Match_bool { match_true ; match_false }) + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( + let%bind (init, match_nil) = fold_map_expression f init match_nil in + let%bind (init, cons) = fold_map_expression f init cons in + ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }) + ) + | Match_option { match_none ; match_some = (name , some, _) } -> ( + let%bind (init, match_none) = fold_map_expression f init match_none in + let%bind (init, some) = fold_map_expression f init some in + ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) }) + ) + | Match_tuple ((names , e), _) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_tuple ((names , e'), [])) + ) + | Match_variant (lst, _) -> ( + let aux init ((a , b) , e) = + let%bind (init,e') = fold_map_expression f init e in + ok (init, ((a , b) , e')) + in + let%bind (init,lst') = bind_fold_map_list aux init lst in + ok @@ (init, Match_variant (lst', ())) + ) diff --git a/src/passes/5-self_ast_sugar/self_ast_sugar.ml b/src/passes/5-self_ast_sugar/self_ast_sugar.ml new file mode 100644 index 000000000..5bac36236 --- /dev/null +++ b/src/passes/5-self_ast_sugar/self_ast_sugar.ml @@ -0,0 +1,25 @@ +open Trace + +let all_expression_mapper = [ +] + +let all_type_expression_mapper = [ +] + +let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper +let all_ty = List.map (fun el -> Helpers.Type_expression el) all_type_expression_mapper + +let all_program = + let all_p = List.map Helpers.map_program all_exp in + let all_p2 = List.map Helpers.map_program all_ty in + bind_chain (List.append all_p all_p2) + +let all_expression = + let all_p = List.map Helpers.map_expression all_expression_mapper in + bind_chain all_p + +let map_expression = Helpers.map_expression + +let fold_expression = Helpers.fold_expression + +let fold_map_expression = Helpers.fold_map_expression 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 261bb1e81..48c43f6d7 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -277,7 +277,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);inline;rhs;let_result} + return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result} | O.E_constructor {constructor;element} -> let%bind element = uncompile_expression element in return @@ I.E_constructor {constructor;element} diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index ebb4bd83e..d25b84dee 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -66,6 +66,27 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a;\n%a" expression expr1 expression expr2 | E_skip -> fprintf ppf "skip" + | E_for {binder; start; final; increment; body} -> + fprintf ppf "for %a from %a to %a by %a do %a" + expression_variable binder + expression start + expression final + expression increment + expression body + | E_for_each {binder; collection; body; _} -> + fprintf ppf "for each %a in %a do %a" + option_map binder + expression collection + expression body + | E_while {condition; body} -> + fprintf ppf "while %a do %a" + expression condition + expression body + +and option_map ppf (k,v_opt) = + match v_opt with + | None -> fprintf ppf "%a" expression_variable k + | Some v -> fprintf ppf "%a -> %a" expression_variable k expression_variable v and option_type_name ppf ((n, ty_opt) : expression_variable * type_expression option) = diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 92a1dbe73..47ec55fb6 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -130,6 +130,11 @@ let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; ar 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_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2} + +let e_while ?loc condition body = make_expr ?loc @@ E_while {condition; body} +let e_for ?loc binder start final increment body = make_expr ?loc @@ E_for {binder;start;final;increment;body} +let e_for_each ?loc binder collection collection_type body = make_expr ?loc @@ E_for_each {binder;collection;collection_type;body} + 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*) diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index ca2f2d552..4d5c4db7a 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -115,6 +115,9 @@ val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression - (* val get_e_accessor : expression' -> ( expression * access_path ) result *) +val e_while : ?loc:Location.t -> expression -> expression -> expression +val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression +val e_for_each : ?loc:Location.t -> expression_variable * expression_variable option -> expression -> collect_type -> expression -> expression val assert_e_accessor : expression_content -> unit result diff --git a/src/stages/1-ast_imperative/misc.ml b/src/stages/1-ast_imperative/misc.ml index 324529525..54e0303cf 100644 --- a/src/stages/1-ast_imperative/misc.ml +++ b/src/stages/1-ast_imperative/misc.ml @@ -184,7 +184,9 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_application _, _) | (E_let_in _, _) | (E_recursive _,_) | (E_record_accessor _, _) | (E_look_up _, _) | (E_matching _, _) - | (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value" + | (E_sequence _, _) | (E_skip, _) + | (E_for _, _) | (E_for_each _, _) + | (E_while _, _) -> simple_fail "comparing not a value" let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 4d0d0bd68..08200dbd7 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -54,6 +54,10 @@ and expression_content = | E_list of expression list | E_set of expression list | E_look_up of (expression * expression) + (* Imperative *) + | E_for of for_ + | E_for_each of for_each + | E_while of while_loop and constant = { cons_name: constant' (* this is at the end because it is huge *) @@ -101,6 +105,31 @@ and sequence = { expr2: expression ; } +and for_ = { + binder : expression_variable; + start : expression; + final : expression; + increment : expression; + body : expression; +} + +and for_each = { + binder : expression_variable * expression_variable option; + collection : expression; + collection_type : collect_type; + body : expression; +} + +and collect_type = + | Map + | Set + | List + +and while_loop = { + condition : expression; + body : expression; +} + and environment_element_definition = | ED_binder | ED_declaration of (expression * free_variables) diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index d4a4ead08..1b65a8046 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -56,10 +56,15 @@ and expression_content ppf (ec : expression_content) = | E_matching {matchee; cases; _} -> fprintf ppf "match %a with %a" expression matchee (matching expression) cases - | 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_let_in { let_binder ; rhs ; let_result; inline; mut} -> + fprintf ppf "let %a%a = %a%a in %a" + option_type_name let_binder + option_mut mut + expression rhs + option_inline inline + expression let_result | E_sequence {expr1;expr2} -> - fprintf ppf "%a;\n%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 759d6fc55..f53344c37 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -122,8 +122,8 @@ let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= 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) inline rhs let_result = - make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline } +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]} diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index e9d3dd144..ca2f2d552 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/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 -> 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 diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 81091dea7..658d30e35 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -76,11 +76,13 @@ and recursive = { lambda : lambda; } -and let_in = - { let_binder: expression_variable * type_expression option - ; rhs: expression - ; let_result: expression - ; inline: bool } +and let_in = { + let_binder: expression_variable * type_expression option ; + rhs: expression ; + let_result: expression ; + inline: bool ; + mut: bool; + } and constructor = {constructor: constructor'; element: expression} diff --git a/src/test/contracts/loop.ligo b/src/test/contracts/loop.ligo index 7866a5cdb..03c1671ba 100644 --- a/src/test/contracts/loop.ligo +++ b/src/test/contracts/loop.ligo @@ -54,9 +54,9 @@ function for_collection_if_and_local_var (var nee : unit) : int is block { var acc : int := 0; const theone : int = 1; + const thetwo : int = 2; var myset : set (int) := set [1; 2; 3]; for x in set myset block { - const thetwo : int = 2; if x = theone then acc := acc + x else if x = thetwo then acc := acc + thetwo else acc := acc + 10