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

add iter for set and lists

Browse Source
This commit is contained in:
galfour 2019-07-20 13:46:42 +02:00
parent 33101820ec
commit 9dd8e63cbf
10 changed files with 145 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
src/compiler/compiler_program.ml
View File

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

10
src/contracts/list.ligo
View File

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

11
src/contracts/set_arithmetic.ligo
View File

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

2
src/mini_c/PP.ml
View File

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

1
src/mini_c/types.ml
View File

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

3
src/operators/operators.ml
View File

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

25
src/simplify/pascaligo.ml
View File

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

8
src/test/integration_tests.ml
View File

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

63
src/transpiler/transpiler.ml
View File

@ -32,11 +32,21 @@ 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) ;
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
@ -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) -> (
| 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
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')
return @@ E_constant (name , lst')
)
)
| E_lambda l ->
let%bind env =

2
vendors/ligo-utils/tezos-utils/x_michelson.ml vendored
View File

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