diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index 26f6255bc..6da10d7c5 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -19,7 +19,7 @@ let get_predicate : string -> type_value -> expression list -> predicate result | "NONE" -> ( let%bind ty' = Mini_c.get_t_option ty in let%bind m_ty = Compiler_type.type_ ty' in - ok @@ simple_unary @@ prim ~children:[m_ty] I_NONE + ok @@ simple_constant @@ prim ~children:[m_ty] I_NONE ) | "NIL" -> ( let%bind ty' = Mini_c.get_t_list ty in @@ -380,6 +380,36 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m ]) in return code ) + | E_iterator (name , (v , body) , expr) -> ( + let%bind (expr' , expr_env) = translate_expression ~push_var_name:"iter_expr" expr env in + let%bind popped = Compiler_environment.pop expr_env in + let%bind env' = ok @@ Environment.add v popped in + let%bind (body' , body_env) = translate_expression ~push_var_name:"iter_body" body env' in + match name with + | "ITER" -> ( + let%bind restrict = + Compiler_environment.select_env body_env popped in + let%bind code = ok (seq [ + expr' ; + i_iter (seq [body' ; restrict]) ; + ]) in + return ~end_env:popped code + ) + | "MAP" -> ( + let%bind restrict = + let%bind popped = Compiler_environment.pop body_env in + Compiler_environment.select_env popped env in + let%bind code = ok (seq [ + expr' ; + i_map (seq [body' ; restrict]) ; + ]) in + return code + ) + | s -> ( + let error = error (thunk "bad iterator") (thunk s) in + fail error + ) + ) | E_assignment (name , lrs , expr) -> ( let%bind (expr' , env') = translate_expression ~push_var_name:"assignment_expr" expr env in let%bind get_code = Compiler_environment.get env' name in diff --git a/src/contracts/list.ligo b/src/contracts/list.ligo index 60af05003..503d72ffb 100644 --- a/src/contracts/list.ligo +++ b/src/contracts/list.ligo @@ -17,3 +17,13 @@ const bl : foobar = list 120 ; 421 ; end + +function iter_op (const s : list(int)) : int is + var r : int := 0 ; + function aggregate (const i : int) : unit is + begin + r := r + i ; + end with unit + begin + list_iter(s , aggregate) ; + end with r diff --git a/src/contracts/set_arithmetic.ligo b/src/contracts/set_arithmetic.ligo index e4c686310..814120c0c 100644 --- a/src/contracts/set_arithmetic.ligo +++ b/src/contracts/set_arithmetic.ligo @@ -1,3 +1,13 @@ +function iter_op (const s : set(int)) : int is + var r : int := 0 ; + function aggregate (const i : int) : unit is + begin + r := r + i ; + end with unit + begin + set_iter(s , aggregate) ; + end with r + const s_e : set(string) = (set_empty : set(string)) const s_fb : set(string) = set [ @@ -13,3 +23,4 @@ function remove_op (const s : set(string)) : set(string) is function mem_op (const s : set(string)) : bool is begin skip end with set_mem("foobar" , s) + diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index bf848723b..3d0e3f065 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -86,6 +86,8 @@ and expression' ppf (e:expression') = match e with | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b | E_let_in ((name , _) , expr , body) -> fprintf ppf "let %s = %a in ( %a )" name expression expr expression body + | E_iterator (s , ((name , _) , body) , expr) -> + fprintf ppf "for_%s %s of %a do ( %a )" s name expression expr expression body | E_assignment (r , path , e) -> fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) path expression e | E_while (e , b) -> diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 77fa0a026..3e9a69819 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -69,6 +69,7 @@ and expression' = | E_make_empty_list of type_value | E_make_empty_set of type_value | E_make_none of type_value + | E_iterator of (string * ((var_name * type_value) * expression) * expression) | E_if_bool of expression * expression * expression | E_if_none of expression * expression * ((var_name * type_value) * expression) | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) diff --git a/src/operators/operators.ml b/src/operators/operators.ml index 4fad1501d..befd3b961 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -79,6 +79,7 @@ module Simplify = struct ("set_add" , "SET_ADD") ; ("set_remove" , "SET_REMOVE") ; ("set_iter" , "SET_ITER") ; + ("list_iter" , "LIST_ITER") ; ] let type_constants = type_constants @@ -585,6 +586,8 @@ module Typer = struct set_mem ; set_add ; set_remove ; + set_iter ; + list_iter ; int ; size ; failwith_ ; diff --git a/src/simplify/pascaligo.ml b/src/simplify/pascaligo.ml index 51aacac92..59667f39a 100644 --- a/src/simplify/pascaligo.ml +++ b/src/simplify/pascaligo.ml @@ -135,7 +135,7 @@ module Errors = struct let unsupported_for_loops region = let title () = "bounded iterators" in let message () = - Format.asprintf "for loops are not supported yet" in + Format.asprintf "only simple for loops are supported yet" in let data = [ ("loop_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ region) @@ -744,8 +744,19 @@ and simpl_statement : Raw.statement -> (_ -> expression result) result = and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result = fun t -> match t with - | ProcCall call -> - fail @@ unsupported_proc_calls call + | ProcCall x -> ( + let ((name, args) , loc) = r_split x in + let (f , f_loc) = r_split name in + let (args , args_loc) = r_split args in + let args' = npseq_to_list args.inside in + match List.assoc_opt f constants with + | None -> + let%bind arg = simpl_tuple_expression ~loc:args_loc args' in + return @@ e_application ~loc (e_variable ~loc:f_loc f) arg + | Some s -> + let%bind lst = bind_map_list simpl_expression args' in + return @@ e_constant ~loc s lst + ) | Fail e -> ( let%bind expr = simpl_expression e.value.fail_expr in return @@ e_failwith expr @@ -760,7 +771,13 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu let%bind body = simpl_block l.block.value in let%bind body = body None in return @@ e_loop cond body - | Loop (For (ForInt {region; _} | ForCollect {region; _})) -> + (* | Loop (For (ForCollect x)) -> ( + * let (x' , loc) = r_split x in + * let%bind expr = simpl_expression x'.expr in + * let%bind body = simpl_block x'.block.value in + * ok _ + * ) *) + | Loop (For (ForInt {region; _} | ForCollect {region ; _})) -> fail @@ unsupported_for_loops region | Cond c -> ( let (c , loc) = r_split c in diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index bd49a31b9..e79ebdd92 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -185,6 +185,10 @@ let set_arithmetic () : unit result = expect_eq program "mem_op" (e_set [e_string "foo" ; e_string "bar"]) (e_bool false) in + let%bind () = + expect_eq program "iter_op" + (e_set [e_int 2 ; e_int 4 ; e_int 7]) + (e_int 13) in ok () let unit_expression () : unit result = @@ -365,6 +369,10 @@ let list () : unit result = let expected = ez [144 ; 51 ; 42 ; 120 ; 421] in expect_eq_evaluate program "bl" expected in + let%bind () = + expect_eq program "iter_op" + (e_list [e_int 2 ; e_int 4 ; e_int 7]) + (e_int 13) in ok () let condition () : unit result = diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index fcaf67815..14b42227a 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -32,12 +32,22 @@ them. please report this to the developers." in let content () = name in error title content + let row_loc l = ("location" , fun () -> Format.asprintf "%a" Location.pp l) + let unsupported_pattern_matching kind location = let title () = "unsupported pattern-matching" in let content () = Format.asprintf "%s patterns aren't supported yet" kind in let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in + row_loc location ; + ] in + error ~data title content + + let unsupported_iterator location = + let title () = "unsupported iterator" in + let content () = "only lambda are supported as iterators" in + let data = [ + row_loc location ; + ] in error ~data title content let not_functional_main location = @@ -341,15 +351,50 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind record' = translate_annotated_expression record in let expr = List.fold_left aux record' path in ok expr - | E_constant (name, lst) -> ( - let%bind lst' = bind_map_list (translate_annotated_expression) lst in - match name, lst with - | "NONE", [] -> - let%bind o = - trace_strong (corner_case ~loc:__LOC__ "not an option") @@ - Mini_c.Combinators.get_t_option tv in - return @@ E_make_none o - | _ -> return @@ E_constant (name, lst') + | E_constant (name , lst) -> ( + let (iter , map) = + let iterator name = fun (lst : AST.annotated_expression list) -> match lst with + | [i ; f] -> ( + let%bind f' = match f.expression with + | E_lambda l -> ( + let%bind body' = translate_annotated_expression l.result in + let%bind input' = translate_type l.input_type in + ok ((l.binder , input') , body') + ) + | E_variable v -> ( + let%bind elt = + trace_option (corner_case ~loc:__LOC__ "missing var") @@ + AST.Environment.get_opt v f.environment in + match elt.definition with + | ED_declaration (f , _) -> ( + match f.expression with + | E_lambda l -> ( + let%bind body' = translate_annotated_expression l.result in + let%bind input' = translate_type l.input_type in + ok ((l.binder , input') , body') + ) + | _ -> fail @@ unsupported_iterator f.location + ) + | _ -> fail @@ unsupported_iterator f.location + ) + | _ -> fail @@ unsupported_iterator f.location + in + let%bind i' = translate_annotated_expression i in + return @@ E_iterator (name , f' , i') + ) + | _ -> fail @@ corner_case ~loc:__LOC__ "bad iterator arity" + in + iterator "ITER" , iterator "MAP" in + match (name , lst) with + | ("SET_ITER" , lst) -> iter lst + | ("LIST_ITER" , lst) -> iter lst + | ("MAP_ITER" , lst) -> iter lst + | ("LIST_MAP" , lst) -> map lst + | ("MAP_MAP" , lst) -> map lst + | _ -> ( + let%bind lst' = bind_map_list (translate_annotated_expression) lst in + return @@ E_constant (name , lst') + ) ) | E_lambda l -> let%bind env = diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 462a40b63..254b93fab 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -48,6 +48,8 @@ let i_push_string str = i_push t_string (string str) let i_none ty = prim ~children:[ty] I_NONE let i_nil ty = prim ~children:[ty] I_NIL let i_empty_set ty = prim ~children:[ty] I_EMPTY_SET +let i_iter body = prim ~children:[body] I_ITER +let i_map body = prim ~children:[body] I_MAP let i_some = prim I_SOME let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA let i_empty_map src dst = prim ~children:[src;dst] I_EMPTY_MAP