diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index c0af289dc..47626335f 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -76,6 +76,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini | E_recursive { lambda={result=e;_}; _} -> let%bind res = self init' e in ok res + | E_cond {condition; then_clause; else_clause} -> + let%bind res = self init' condition in + let%bind res = self res then_clause in + let%bind res = self res else_clause in + ok res | E_sequence {expr1;expr2} -> let ab = (expr1,expr2) in let%bind res = bind_fold_pair self init' ab in @@ -217,6 +222,11 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind args = bind_map_list self c.arguments in return @@ E_constant {c with arguments=args} ) + | E_cond {condition; then_clause; else_clause} -> + let%bind condition = self condition in + let%bind then_clause = self then_clause in + let%bind else_clause = self else_clause in + return @@ E_cond {condition;then_clause;else_clause} | E_sequence {expr1;expr2} -> ( let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in return @@ E_sequence {expr1;expr2} @@ -396,6 +406,11 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,args) = bind_fold_map_list self init' c.arguments in ok (res, return @@ E_constant {c with arguments=args}) ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res,condition = self init' condition in + let%bind res,then_clause = self res then_clause in + let%bind res,else_clause = self res else_clause in + ok (res, return @@ E_cond {condition;then_clause;else_clause}) | 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}) 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 89e5d99fb..4a69e6c67 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -234,6 +234,28 @@ 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_cond {condition;then_clause;else_clause} -> + let%bind condition = compile_expression condition in + let%bind then_clause' = compile_expression then_clause in + let%bind else_clause' = compile_expression else_clause in + let env = Var.fresh () in + let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in + let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in + let then_clause = add_to_end then_clause (O.e_variable env) in + let else_clause = add_to_end else_clause (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 cond_expr = O.e_cond condition then_clause else_clause 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 cond_expr @@ + expr + } + in + return @@ restore_mutable_variable return_expr free_vars env + else + return @@ O.E_cond {condition; then_clause=then_clause'; else_clause=else_clause'} | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in @@ -672,6 +694,11 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind anno_expr = uncompile_expression anno_expr in let%bind type_annotation = uncompile_type_expression type_annotation in return @@ I.E_ascription {anno_expr; type_annotation} + | O.E_cond {condition;then_clause;else_clause} -> + let%bind condition = uncompile_expression condition in + let%bind then_clause = uncompile_expression then_clause in + let%bind else_clause = uncompile_expression else_clause in + return @@ I.E_cond {condition; then_clause; else_clause} | O.E_sequence {expr1; expr2} -> let%bind expr1 = uncompile_expression expr1 in let%bind expr2 = uncompile_expression expr2 in diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml index 46b9e4cfd..7ac208768 100644 --- a/src/passes/5-self_ast_sugar/helpers.ml +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -56,6 +56,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self res let_result in ok res ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res = self init' condition in + let%bind res = self res then_clause in + let%bind res = self res else_clause in + ok res | E_recursive { lambda={result=e;_}; _} -> let%bind res = self init' e in ok res @@ -189,6 +194,11 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind args = bind_map_list self c.arguments in return @@ E_constant {c with arguments=args} ) + | E_cond {condition; then_clause; else_clause} -> + let%bind condition = self condition in + let%bind then_clause = self then_clause in + let%bind else_clause = self else_clause in + return @@ E_cond {condition;then_clause;else_clause} | E_sequence {expr1;expr2} -> ( let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in return @@ E_sequence {expr1;expr2} @@ -365,6 +375,11 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,args) = bind_fold_map_list self init' c.arguments in ok (res, return @@ E_constant {c with arguments=args}) ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res,condition = self init' condition in + let%bind res,then_clause = self res then_clause in + let%bind res,else_clause = self res else_clause in + ok (res, return @@ E_cond {condition;then_clause;else_clause}) | 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}) 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 1d6270dcb..b175f8eb3 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -154,6 +154,11 @@ let rec compile_expression : I.expression -> O.expression result = let%bind anno_expr = compile_expression anno_expr in let%bind type_annotation = idle_type_expression type_annotation in return @@ O.E_ascription {anno_expr; type_annotation} + | I.E_cond {condition; then_clause; else_clause} -> + let%bind matchee = compile_expression condition in + let%bind match_true = compile_expression then_clause in + let%bind match_false = compile_expression else_clause in + return @@ O.E_matching {matchee; cases=Match_bool{match_true;match_false}} | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 2e8ff28a1..a9ca9fe03 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -96,6 +96,11 @@ and expression_content ppf (ec : expression_content) = | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation + | E_cond {condition; then_clause; else_clause} -> + fprintf ppf "if %a then %a else %a" + expression condition + expression then_clause + expression else_clause | E_sequence {expr1;expr2} -> fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_skip -> diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 2dd149b8a..a71f5268e 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -131,7 +131,7 @@ 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_cond ?loc condition then_clause else_clause = make_expr ?loc @@ E_cond {condition;then_clause;else_clause} (* 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/misc.ml b/src/stages/1-ast_imperative/misc.ml index 1c37f1744..884822fff 100644 --- a/src/stages/1-ast_imperative/misc.ml +++ b/src/stages/1-ast_imperative/misc.ml @@ -204,7 +204,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_application _, _) | (E_let_in _, _) | (E_recursive _,_) | (E_record_accessor _, _) | (E_tuple_accessor _, _) - | (E_look_up _, _) | (E_matching _, _) + | (E_look_up _, _) + | (E_matching _, _) | (E_cond _, _) | (E_sequence _, _) | (E_skip, _) | (E_assign _, _) | (E_for _, _) | (E_for_each _, _) diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index ee69248ba..6c396fb08 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -60,6 +60,7 @@ and expression_content = (* Advanced *) | E_ascription of ascription (* Sugar *) + | E_cond of conditional | E_sequence of sequence | E_skip | E_tuple of expression list @@ -118,6 +119,13 @@ and matching = } and ascription = {anno_expr: expression; type_annotation: type_expression} + +and conditional = { + condition : expression ; + then_clause : expression ; + else_clause : expression ; +} + and sequence = { expr1: expression ; expr2: expression ; diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index e2f86622e..b57e65bcb 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -93,10 +93,15 @@ and expression_content ppf (ec : expression_content) = expression rhs option_inline inline expression let_result - | E_sequence {expr1;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_cond {condition; then_clause; else_clause} -> + fprintf ppf "if %a then %a else %a" + expression condition + expression then_clause + expression else_clause + | E_sequence {expr1;expr2} -> + fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_skip -> fprintf ppf "skip" | E_tuple t -> diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index cc18739c2..4edfc377f 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -122,6 +122,7 @@ let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; ar let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} +let e_cond ?loc condition then_clause else_clause = make_expr ?loc @@ E_cond {condition;then_clause;else_clause} let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2} let e_skip ?loc () = make_expr ?loc @@ E_skip @@ -153,7 +154,6 @@ let make_option_typed ?loc e t_opt = | 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] diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index a8d7b5919..1fa10df89 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -84,6 +84,7 @@ val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> exp val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression +val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_sequence : ?loc:Location.t -> expression -> expression -> expression val e_skip : ?loc:Location.t -> unit -> expression @@ -109,7 +110,6 @@ val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> ty val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression 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 diff --git a/src/stages/2-ast_sugar/misc.ml b/src/stages/2-ast_sugar/misc.ml index 2d43bf2a9..508ae70d9 100644 --- a/src/stages/2-ast_sugar/misc.ml +++ b/src/stages/2-ast_sugar/misc.ml @@ -204,7 +204,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_application _, _) | (E_let_in _, _) | (E_recursive _,_) | (E_record_accessor _, _) | (E_tuple_accessor _, _) - | (E_look_up _, _) | (E_matching _, _) + | (E_look_up _, _) + | (E_matching _, _) | (E_cond _, _) | (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value" let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index f4650284c..cd648c754 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -60,6 +60,7 @@ and expression_content = (* Advanced *) | E_ascription of ascription (* Sugar *) + | E_cond of conditional | E_sequence of sequence | E_skip | E_tuple of expression list @@ -113,6 +114,12 @@ and matching = } and ascription = {anno_expr: expression; type_annotation: type_expression} + +and conditional = { + condition : expression ; + then_clause : expression ; + else_clause : expression ; +} and sequence = { expr1: expression ; expr2: expression ;