diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml index 054c9e00d..663c989e7 100644 --- a/src/main/compile/helpers.ml +++ b/src/main/compile/helpers.ml @@ -63,7 +63,7 @@ let parsify = fun (syntax : v_syntax) source_filename -> | Cameligo -> ok parsify_ligodity in let%bind parsified = parsify source_filename in - let%bind applied = Self_ast_simplified.convert_annotation_program parsified in + let%bind applied = Self_ast_simplified.all_program parsified in ok applied let parsify_expression = fun syntax source -> @@ -72,5 +72,5 @@ let parsify_expression = fun syntax source -> | Cameligo -> ok parsify_expression_ligodity in let%bind parsified = parsify source in - let%bind applied = Self_ast_simplified.convert_annotation_expression parsified in + let%bind applied = Self_ast_simplified.all_expression parsified in ok applied diff --git a/src/passes/2-simplify/ligodity.ml b/src/passes/2-simplify/ligodity.ml index 3a1fe5132..879579e9f 100644 --- a/src/passes/2-simplify/ligodity.ml +++ b/src/passes/2-simplify/ligodity.ml @@ -434,7 +434,7 @@ let rec simpl_expression : | EArith (Mtz n) -> ( let (n , loc) = r_split n in let n = Z.to_int @@ snd @@ n in - return @@ e_literal ~loc (Literal_tez n) + return @@ e_literal ~loc (Literal_mutez n) ) | EArith _ as e -> fail @@ unsupported_arith_op e diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 0a6fe63d3..5380e9f0e 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -500,7 +500,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = | EArith (Mtz n) -> ( let (n , loc) = r_split n in let n = Z.to_int @@ snd @@ n in - return @@ e_literal ~loc (Literal_tez n) + return @@ e_literal ~loc (Literal_mutez n) ) | EArith (Neg e) -> simpl_unop "NEG" e | EString (String s) -> diff --git a/src/passes/3-self_ast_simplified/literals.ml b/src/passes/3-self_ast_simplified/literals.ml new file mode 100644 index 000000000..5d7be25b6 --- /dev/null +++ b/src/passes/3-self_ast_simplified/literals.ml @@ -0,0 +1,53 @@ +open Ast_simplified +open Trace + +let peephole_expression : expression -> expression result = fun e -> + let return expression = ok { e with expression } in + match e.expression with + | E_constant ("MAP_LITERAL" , lst) -> ( + let%bind elt = + trace_option (simple_error "map literal expects a single parameter") @@ + List.to_singleton lst + in + let%bind lst = + trace (simple_error "map literal expects a list as parameter") @@ + get_e_list elt.expression + in + let aux = fun (e : expression) -> + trace (simple_error "map literal expects a list of pairs as parameter") @@ + let%bind tpl = get_e_tuple e.expression in + let%bind (a , b) = + trace_option (simple_error "of pairs") @@ + List.to_pair tpl + in + ok (a , b) + in + let%bind pairs = bind_map_list aux lst in + return @@ E_map pairs + ) + | E_constant ("MAP_EMPTY" , lst) -> ( + let%bind () = + trace_strong (simple_error "MAP_EMPTY expects no parameter") @@ + Assert.assert_list_empty lst + in + return @@ E_map [] + ) + | E_constant ("SET_LITERAL" , lst) -> ( + let%bind elt = + trace_option (simple_error "map literal expects a single parameter") @@ + List.to_singleton lst + in + let%bind lst = + trace (simple_error "map literal expects a list as parameter") @@ + get_e_list elt.expression + in + return @@ E_set lst + ) + | E_constant ("SET_EMPTY" , lst) -> ( + let%bind () = + trace_strong (simple_error "SET_EMPTY expects no parameter") @@ + Assert.assert_list_empty lst + in + return @@ E_set [] + ) + | e -> return e diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml index b3ebb08db..aa18b4a8c 100644 --- a/src/passes/3-self_ast_simplified/self_ast_simplified.ml +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -1,3 +1,23 @@ -let convert_annotation_expression = Helpers.map_expression Tezos_type_annotation.peephole_expression -let convert_annotation_program = Helpers.map_program Tezos_type_annotation.peephole_expression -let convert_none_variant_to_const = Helpers.map_program None_variant.peephole_expression +open Trace + +let all = [ + Tezos_type_annotation.peephole_expression ; + None_variant.peephole_expression ; + Literals.peephole_expression ; +] + +let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> + match fs with + | [] -> ok x + | hd :: tl -> ( + let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in + bind aux (ok x) + ) + +let all_program = + let all_p = List.map Helpers.map_program all in + bind_chain all_p + +let all_expression = + let all_p = List.map Helpers.map_expression all in + bind_chain all_p diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 2cacd1629..5c87cfe62 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -416,8 +416,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_literal (Literal_nat n)) (t_nat ()) | E_literal (Literal_timestamp n) -> return (E_literal (Literal_timestamp n)) (t_timestamp ()) - | E_literal (Literal_tez n) -> - return (E_literal (Literal_tez n)) (t_tez ()) + | E_literal (Literal_mutez n) -> + return (E_literal (Literal_mutez n)) (t_tez ()) | E_literal (Literal_address s) -> return (e_address s) (t_address ()) | E_literal (Literal_operation op) -> @@ -803,7 +803,7 @@ let untype_literal (l:O.literal) : I.literal result = | Literal_bool b -> ok (Literal_bool b) | Literal_nat n -> ok (Literal_nat n) | Literal_timestamp n -> ok (Literal_timestamp n) - | Literal_tez n -> ok (Literal_tez n) + | Literal_mutez n -> ok (Literal_mutez n) | Literal_int n -> ok (Literal_int n) | Literal_string s -> ok (Literal_string s) | Literal_bytes b -> ok (Literal_bytes b) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 9fbf55374..ef3207d2b 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -204,7 +204,7 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with | Literal_int n -> D_int n | Literal_nat n -> D_nat n | Literal_timestamp n -> D_timestamp n - | Literal_tez n -> D_tez n + | Literal_mutez n -> D_mutez n | Literal_bytes s -> D_bytes s | Literal_string s -> D_string s | Literal_address s -> D_string s @@ -361,47 +361,54 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let expr = List.fold_left aux record' path in ok expr | 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' = transpile_annotated_expression l.body in - let%bind (input , _) = AST.get_t_function f.type_annotation in - let%bind input' = transpile_type input 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' = transpile_annotated_expression l.body in - let%bind (input , _) = AST.get_t_function f.type_annotation in - let%bind input' = transpile_type input 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' = transpile_annotated_expression i in - return @@ E_iterator (name , f' , i') - ) - | _ -> fail @@ corner_case ~loc:__LOC__ "bad iterator arity" + let iterator_generator iterator_name = + let lambda_to_iterator_body (f : AST.annotated_expression) (l : AST.lambda) = + let%bind body' = transpile_annotated_expression l.body in + let%bind (input , _) = AST.get_t_function f.type_annotation in + let%bind input' = transpile_type input in + ok ((l.binder , input') , body') in - iterator "ITER" , iterator "MAP" in + let expression_to_iterator_body (f : AST.annotated_expression) = + match f.expression with + | E_lambda l -> lambda_to_iterator_body f l + | 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 -> lambda_to_iterator_body f l + | _ -> fail @@ unsupported_iterator f.location + ) + | _ -> fail @@ unsupported_iterator f.location + ) + | _ -> fail @@ unsupported_iterator f.location + in + fun (lst : AST.annotated_expression list) -> match (lst , iterator_name) with + | [i ; f] , "ITER" | [i ; f] , "MAP" -> ( + let%bind f' = expression_to_iterator_body f in + let%bind i' = transpile_annotated_expression i in + return @@ E_iterator (iterator_name , f' , i') + ) + | [ collection ; initial ; f ] , "FOLD" -> ( + let%bind f' = expression_to_iterator_body f in + let%bind initial' = transpile_annotated_expression initial in + let%bind collection' = transpile_annotated_expression collection in + return @@ E_fold (f' , collection' , initial') + ) + | _ -> fail @@ corner_case ~loc:__LOC__ ("bad iterator arity:" ^ iterator_name) + in + let (iter , map , fold) = iterator_generator "ITER" , iterator_generator "MAP" , iterator_generator "FOLD" 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 + | ("LIST_FOLD" , lst) -> fold lst + | ("SET_FOLD" , lst) -> fold lst + | ("MAP_FOLD" , lst) -> fold lst | _ -> ( let%bind lst' = bind_map_list (transpile_annotated_expression) lst in return @@ E_constant (name , lst') diff --git a/src/passes/6-transpiler/untranspiler.ml b/src/passes/6-transpiler/untranspiler.ml index 6c0309bd3..78c41cca8 100644 --- a/src/passes/6-transpiler/untranspiler.ml +++ b/src/passes/6-transpiler/untranspiler.ml @@ -86,8 +86,8 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression | T_constant ("tez", []) -> ( let%bind n = trace_strong (wrong_mini_c_value "tez" v) @@ - get_nat v in - return (E_literal (Literal_tez n)) + get_mutez v in + return (E_literal (Literal_mutez n)) ) | T_constant ("string", []) -> ( let%bind n = diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 8d42c1d3d..ef3d19395 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -66,7 +66,7 @@ let rec translate_value (v:value) ty : michelson result = match v with | D_int n -> ok @@ int (Z.of_int n) | D_nat n -> ok @@ int (Z.of_int n) | D_timestamp n -> ok @@ int (Z.of_int n) - | D_tez n -> ok @@ int (Z.of_int n) + | D_mutez n -> ok @@ int (Z.of_int n) | D_string s -> ok @@ string s | D_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s) | D_unit -> ok @@ prim D_Unit @@ -339,6 +339,20 @@ and translate_expression (expr:expression) (env:environment) : michelson result fail error ) ) + | E_fold ((v , body) , collection , initial) -> ( + let%bind collection' = translate_expression collection env in + let%bind initial' = translate_expression initial env in + let%bind body' = translate_expression body (Environment.add v env) in + let code = seq [ + collection' ; + dip initial' ; + i_iter (seq [ + i_swap ; + i_pair ; body' ; dip i_drop ; + ]) ; + ] in + ok code + ) | E_assignment (name , lrs , expr) -> ( let%bind expr' = translate_expression expr env in let%bind get_code = Compiler_environment.get env name in diff --git a/src/passes/8-compiler/uncompiler.ml b/src/passes/8-compiler/uncompiler.ml index 2838298d3..310d3a72f 100644 --- a/src/passes/8-compiler/uncompiler.ml +++ b/src/passes/8-compiler/uncompiler.ml @@ -40,7 +40,7 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = let%bind n = generic_try (simple_error "too big to fit an int") @@ (fun () -> Int64.to_int @@ Alpha_context.Tez.to_mutez n) in - ok @@ D_nat n + ok @@ D_mutez n | (Bool_t _), b -> ok @@ D_bool b | (String_t _), s -> diff --git a/src/passes/operators/helpers.ml b/src/passes/operators/helpers.ml index 8fd18a16f..b588605f2 100644 --- a/src/passes/operators/helpers.ml +++ b/src/passes/operators/helpers.ml @@ -104,7 +104,7 @@ module Typer = struct let eq_1 a cst = type_value_eq (a , cst) let eq_2 (a , b) cst = type_value_eq (a , cst) && type_value_eq (b , cst) - let assert_eq_1 a b = Assert.assert_true (eq_1 a b) + let assert_eq_1 ?msg a b = Assert.assert_true ?msg (eq_1 a b) let comparator : string -> typer = fun s -> typer_2 s @@ fun a b -> let%bind () = diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 71a135f7c..75b940e22 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -81,10 +81,16 @@ module Simplify = struct ("set_add" , "SET_ADD") ; ("set_remove" , "SET_REMOVE") ; ("set_iter" , "SET_ITER") ; + ("set_fold" , "SET_FOLD") ; ("list_iter" , "LIST_ITER") ; + ("list_fold" , "LIST_FOLD") ; ("list_map" , "LIST_MAP") ; ("map_iter" , "MAP_ITER") ; ("map_map" , "MAP_MAP") ; + ("map_fold" , "MAP_FOLD") ; + ("map_remove" , "MAP_REMOVE") ; + ("map_update" , "MAP_UPDATE") ; + ("map_get" , "MAP_GET") ; ("sha_256" , "SHA256") ; ("sha_512" , "SHA512") ; ("blake2b" , "BLAKE2b") ; @@ -144,14 +150,21 @@ module Simplify = struct ("Set.mem" , "SET_MEM") ; ("Set.empty" , "SET_EMPTY") ; + ("Set.literal" , "SET_LITERAL") ; ("Set.add" , "SET_ADD") ; ("Set.remove" , "SET_REMOVE") ; + ("Set.fold" , "SET_FOLD") ; ("Map.find_opt" , "MAP_FIND_OPT") ; ("Map.find" , "MAP_FIND") ; ("Map.update" , "MAP_UPDATE") ; ("Map.add" , "MAP_ADD") ; ("Map.remove" , "MAP_REMOVE") ; + ("Map.iter" , "MAP_ITER") ; + ("Map.map" , "MAP_MAP") ; + ("Map.fold" , "MAP_FOLD") ; + ("Map.empty" , "MAP_EMPTY") ; + ("Map.literal" , "MAP_LITERAL" ) ; ("String.length", "SIZE") ; ("String.size", "SIZE") ; @@ -161,7 +174,9 @@ module Simplify = struct ("List.length", "SIZE") ; ("List.size", "SIZE") ; - ("List.iter", "ITER") ; + ("List.iter", "LIST_ITER") ; + ("List.map" , "LIST_MAP") ; + ("List.fold" , "LIST_FOLD") ; ("Operation.transaction" , "CALL") ; ("Operation.get_contract" , "CONTRACT") ; @@ -258,7 +273,9 @@ module Typer = struct ok @@ t_bool () let map_find : typer = typer_2 "MAP_FIND" @@ fun k m -> - let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in + let%bind (src, dst) = + trace_strong (simple_error "MAP_FIND: not map or bigmap") @@ + bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in ok @@ dst @@ -280,16 +297,6 @@ module Typer = struct let%bind () = assert_eq_1 arg (t_pair k v ()) in ok @@ t_map k res () - let map_fold : typer = typer_2 "MAP_FOLD" @@ fun f m -> - let%bind (k, v) = get_t_map m in - let%bind (arg_1 , res) = get_t_function f in - let%bind (arg_2 , res') = get_t_function res in - let%bind (arg_3 , res'') = get_t_function res' in - let%bind () = assert_eq_1 arg_1 k in - let%bind () = assert_eq_1 arg_2 v in - let%bind () = assert_eq_1 arg_3 res'' in - ok @@ res' - let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ @@ -311,11 +318,16 @@ module Typer = struct (is_t_string t) in ok @@ t_unit () - let get_force = typer_2 "MAP_GET_FORCE" @@ fun i m -> + let map_get_force = typer_2 "MAP_GET_FORCE" @@ fun i m -> let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind _ = assert_type_value_eq (src, i) in ok dst + let map_get = typer_2 "MAP_GET" @@ fun i m -> + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in + let%bind _ = assert_type_value_eq (src, i) in + ok @@ t_option dst () + let int : typer = typer_1 "INT" @@ fun t -> let%bind () = assert_t_nat t in ok @@ t_int () @@ -483,7 +495,49 @@ module Typer = struct let%bind key = get_t_list lst in if eq_1 key arg then ok (t_list res ()) - else simple_fail "bad list iter" + else simple_fail "bad list map" + + let list_fold = typer_3 "LIST_FOLD" @@ fun lst init body -> + let%bind (arg , res) = get_t_function body in + let%bind (prec , cur) = get_t_pair arg in + let%bind key = get_t_list lst in + let msg = Format.asprintf "%a vs %a" + Ast_typed.PP.type_value key + Ast_typed.PP.type_value arg + in + trace (simple_error ("bad list fold:" ^ msg)) @@ + let%bind () = assert_eq_1 ~msg:"key cur" key cur in + let%bind () = assert_eq_1 ~msg:"prec res" prec res in + let%bind () = assert_eq_1 ~msg:"res init" res init in + ok res + + let set_fold = typer_3 "SET_FOLD" @@ fun lst init body -> + let%bind (arg , res) = get_t_function body in + let%bind (prec , cur) = get_t_pair arg in + let%bind key = get_t_set lst in + let msg = Format.asprintf "%a vs %a" + Ast_typed.PP.type_value key + Ast_typed.PP.type_value arg + in + trace (simple_error ("bad set fold:" ^ msg)) @@ + let%bind () = assert_eq_1 ~msg:"key cur" key cur in + let%bind () = assert_eq_1 ~msg:"prec res" prec res in + let%bind () = assert_eq_1 ~msg:"res init" res init in + ok res + + let map_fold = typer_3 "MAP_FOLD" @@ fun map init body -> + let%bind (arg , res) = get_t_function body in + let%bind (prec , cur) = get_t_pair arg in + let%bind (key , value) = get_t_map map in + let msg = Format.asprintf "%a vs %a" + Ast_typed.PP.type_value key + Ast_typed.PP.type_value arg + in + trace (simple_error ("bad list fold:" ^ msg)) @@ + let%bind () = assert_eq_1 ~msg:"key cur" (t_pair key value ()) cur in + let%bind () = assert_eq_1 ~msg:"prec res" prec res in + let%bind () = assert_eq_1 ~msg:"res init" res init in + ok res let not_ = typer_1 "NOT" @@ fun elt -> if eq_1 elt (t_bool ()) @@ -563,17 +617,20 @@ module Typer = struct map_map ; map_fold ; map_iter ; + map_get_force ; + map_get ; set_empty ; set_mem ; set_add ; set_remove ; set_iter ; + set_fold ; list_iter ; list_map ; + list_fold ; int ; size ; failwith_ ; - get_force ; bytes_pack ; bytes_unpack ; hash256 ; @@ -641,6 +698,7 @@ module Compiler = struct ("MAP_GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ; ("MAP_FIND" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) ; ("MAP_GET" , simple_binary @@ prim I_GET) ; + ("MAP_FIND_OPT" , simple_binary @@ prim I_GET) ; ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ; ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SIZE" , simple_unary @@ prim I_SIZE) ; diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml index 6ddef98c6..1fb7cb18e 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/ast_simplified/PP.ml @@ -25,7 +25,7 @@ let literal ppf (l:literal) = match l with | Literal_int n -> fprintf ppf "%d" n | Literal_nat n -> fprintf ppf "+%d" n | Literal_timestamp n -> fprintf ppf "+%d" n - | Literal_tez n -> fprintf ppf "%dtz" n + | Literal_mutez n -> fprintf ppf "%dmtz" n | Literal_string s -> fprintf ppf "%S" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_address s -> fprintf ppf "@%S" s diff --git a/src/stages/ast_simplified/combinators.ml b/src/stages/ast_simplified/combinators.ml index 6260229ad..0890365d1 100644 --- a/src/stages/ast_simplified/combinators.ml +++ b/src/stages/ast_simplified/combinators.ml @@ -61,7 +61,7 @@ let e_timestamp ?loc n : expression = location_wrap ?loc @@ E_literal (Literal_t let e_bool ?loc b : expression = location_wrap ?loc @@ E_literal (Literal_bool b) let e_string ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_string s) let e_address ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_address s) -let e_tez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_tez s) +let e_mutez ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_mutez s) let e'_bytes b : expression' result = let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in ok @@ E_literal (Literal_bytes bytes) @@ -162,6 +162,11 @@ let get_e_list = fun t -> | E_list lst -> ok lst | _ -> simple_fail "not a list" +let get_e_tuple = fun t -> + match t with + | E_tuple lst -> ok lst + | _ -> simple_fail "not a tuple" + let get_e_failwith = fun e -> match e.expression with | E_failwith fw -> ok fw diff --git a/src/stages/ast_simplified/misc.ml b/src/stages/ast_simplified/misc.ml index 9484b1f09..ec9044c8a 100644 --- a/src/stages/ast_simplified/misc.ml +++ b/src/stages/ast_simplified/misc.ml @@ -45,9 +45,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_timestamp a, Literal_timestamp b when a = b -> ok () | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b - | Literal_tez a, Literal_tez b when a = b -> ok () - | Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b - | Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b + | Literal_mutez a, Literal_mutez b when a = b -> ok () + | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b + | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b | Literal_string a, Literal_string b when a = b -> ok () | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b diff --git a/src/stages/ast_simplified/types.ml b/src/stages/ast_simplified/types.ml index 1ca2a19cf..ea42d849d 100644 --- a/src/stages/ast_simplified/types.ml +++ b/src/stages/ast_simplified/types.ml @@ -91,7 +91,7 @@ and literal = | Literal_bool of bool | Literal_int of int | Literal_nat of int - | Literal_tez of int + | Literal_mutez of int | Literal_string of string | Literal_bytes of bytes | Literal_address of string diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 9af3eb49a..96825ecc3 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -70,7 +70,7 @@ and literal ppf (l:literal) : unit = | Literal_int n -> fprintf ppf "%d" n | Literal_nat n -> fprintf ppf "+%d" n | Literal_timestamp n -> fprintf ppf "+%d" n - | Literal_tez n -> fprintf ppf "%dtz" n + | Literal_mutez n -> fprintf ppf "%dmtz" n | Literal_string s -> fprintf ppf "%s" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_address s -> fprintf ppf "@%s" s diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 1f4047d5b..d9dcebb73 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -232,7 +232,7 @@ let e_map lst : expression = E_map lst let e_unit : expression = E_literal (Literal_unit) let e_int n : expression = E_literal (Literal_int n) let e_nat n : expression = E_literal (Literal_nat n) -let e_tez n : expression = E_literal (Literal_tez n) +let e_mutez n : expression = E_literal (Literal_mutez n) let e_bool b : expression = E_literal (Literal_bool b) let e_string s : expression = E_literal (Literal_string s) let e_address s : expression = E_literal (Literal_address s) @@ -247,7 +247,7 @@ let e_let_in binder rhs result = E_let_in { binder ; rhs ; result } let e_a_unit = make_a_e e_unit (t_unit ()) let e_a_int n = make_a_e (e_int n) (t_int ()) let e_a_nat n = make_a_e (e_nat n) (t_nat ()) -let e_a_tez n = make_a_e (e_tez n) (t_tez ()) +let e_a_mutez n = make_a_e (e_mutez n) (t_tez ()) let e_a_bool b = make_a_e (e_bool b) (t_bool ()) let e_a_string s = make_a_e (e_string s) (t_string ()) let e_a_address s = make_a_e (e_address s) (t_address ()) diff --git a/src/stages/ast_typed/combinators_environment.ml b/src/stages/ast_typed/combinators_environment.ml index 4c41f7296..1446c8780 100644 --- a/src/stages/ast_typed/combinators_environment.ml +++ b/src/stages/ast_typed/combinators_environment.ml @@ -6,7 +6,7 @@ let make_a_e_empty expression type_annotation = make_a_e expression type_annotat let e_a_empty_unit = e_a_unit Environment.full_empty let e_a_empty_int n = e_a_int n Environment.full_empty let e_a_empty_nat n = e_a_nat n Environment.full_empty -let e_a_empty_tez n = e_a_tez n Environment.full_empty +let e_a_empty_mutez n = e_a_mutez n Environment.full_empty let e_a_empty_bool b = e_a_bool b Environment.full_empty let e_a_empty_string s = e_a_string s Environment.full_empty let e_a_empty_address s = e_a_address s Environment.full_empty diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 39b437060..5aaf28550 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -365,9 +365,9 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_timestamp a, Literal_timestamp b when a = b -> ok () | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b - | Literal_tez a, Literal_tez b when a = b -> ok () - | Literal_tez _, Literal_tez _ -> fail @@ different_literals "different tezs" a b - | Literal_tez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b + | Literal_mutez a, Literal_mutez b when a = b -> ok () + | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b + | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b | Literal_string a, Literal_string b when a = b -> ok () | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index ce5627086..fc297b593 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -119,7 +119,7 @@ and literal = | Literal_int of int | Literal_nat of int | Literal_timestamp of int - | Literal_tez of int + | Literal_mutez of int | Literal_string of string | Literal_bytes of bytes | Literal_address of string diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index f3863dca6..660006521 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -49,7 +49,7 @@ let rec value ppf : value -> unit = function | D_int n -> fprintf ppf "%d" n | D_nat n -> fprintf ppf "+%d" n | D_timestamp n -> fprintf ppf "+%d" n - | D_tez n -> fprintf ppf "%dtz" n + | D_mutez n -> fprintf ppf "%dmtz" n | D_unit -> fprintf ppf "unit" | D_string s -> fprintf ppf "\"%s\"" s | D_bytes x -> @@ -90,6 +90,8 @@ and expression' ppf (e:expression') = match e with 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_fold (((name , _) , body) , collection , initial) -> + fprintf ppf "fold %a on %a with %s do ( %a )" expression collection expression initial name 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/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml index 074d66618..094d91928 100644 --- a/src/stages/mini_c/combinators.ml +++ b/src/stages/mini_c/combinators.ml @@ -34,6 +34,10 @@ let get_nat (v:value) = match v with | D_nat n -> ok n | _ -> simple_fail "not a nat" +let get_mutez (v:value) = match v with + | D_mutez n -> ok n + | _ -> simple_fail "not a mutez" + let get_timestamp (v:value) = match v with | D_timestamp n -> ok n | _ -> simple_fail "not a timestamp" diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index f7fdb0d05..a0a367409 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -38,7 +38,7 @@ type value = | D_bool of bool | D_nat of int | D_timestamp of int - | D_tez of int + | D_mutez of int | D_int of int | D_string of string | D_bytes of bytes @@ -69,6 +69,7 @@ and expression' = | E_make_empty_set of type_value | E_make_none of type_value | E_iterator of (string * ((var_name * type_value) * expression) * expression) + | E_fold of (((var_name * type_value) * expression) * expression * expression) | E_if_bool of expression * expression * expression | E_if_none of expression * expression * ((var_name * type_value) * expression) | E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression)) diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index 7b7b38ae8..967130f3d 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -47,7 +47,7 @@ let card_pattern_ty = ] let card_pattern_ez (coeff , qtt) = - card_pattern (e_tez coeff , e_nat qtt) + card_pattern (e_mutez coeff , e_nat qtt) let make_card_patterns lst = let card_pattern_id_ty = t_nat in diff --git a/src/test/contracts/list.mligo b/src/test/contracts/list.mligo index 34450fde8..77bd98fc2 100644 --- a/src/test/contracts/list.mligo +++ b/src/test/contracts/list.mligo @@ -12,3 +12,15 @@ let%entry main (p : param) storage = [] -> storage | hd::tl -> storage.(0) + hd, tl in (([] : operation list), storage) + +let fold_op (s : int list) : int = + let aggregate = fun (prec : int) (cur : int) -> prec + cur in + List.fold s 10 aggregate + +let map_op (s : int list) : int list = + let aggregate = fun (cur : int) -> cur + 1 in + List.map s aggregate + +let iter_op (s : int list) : unit = + let do_nothing = fun (cur : int) -> unit in + List.iter s do_nothing diff --git a/src/test/contracts/map.ligo b/src/test/contracts/map.ligo index af3697768..dd6770077 100644 --- a/src/test/contracts/map.ligo +++ b/src/test/contracts/map.ligo @@ -26,6 +26,11 @@ function get (const m : foobar) : option(int) is skip end with m[42] +function get_ (const m : foobar) : option(int) is + begin + skip + end with map_get(42 , m) + const bm : foobar = map 144 -> 23 ; 51 -> 23 ; @@ -44,3 +49,7 @@ function iter_op (const m : foobar) : int is function map_op (const m : foobar) : foobar is function increment (const i : int ; const j : int) : int is block { skip } with j + 1 ; block { skip } with map_map(m , increment) ; + +function fold_op (const m : foobar) : int is + function aggregate (const i : int ; const j : (int * int)) : int is block { skip } with i + j.0 + j.1 ; + block { skip } with map_fold(m , 10 , aggregate) diff --git a/src/test/contracts/map.mligo b/src/test/contracts/map.mligo new file mode 100644 index 000000000..375a69507 --- /dev/null +++ b/src/test/contracts/map.mligo @@ -0,0 +1,7 @@ +type foobar = (int , int) map + +let foobar : foobar = Map.empty + +let foobarz : foobar = Map.literal [ (1 , 10) ; (2 , 20) ] + +let foo : int = Map.find 1 foobarz diff --git a/src/test/contracts/set_arithmetic-1.ligo b/src/test/contracts/set_arithmetic-1.ligo index 0cfab61d2..f5d332687 100644 --- a/src/test/contracts/set_arithmetic-1.ligo +++ b/src/test/contracts/set_arithmetic-1.ligo @@ -9,3 +9,8 @@ function iter_op (const s : set(int)) : int is begin set_iter(s , aggregate) ; end with r + +function fold_op (const s : set(int)) : int is + function aggregate (const i : int ; const j : int) : int is + block { skip } with i + j + block { skip } with set_fold(s , 15 , aggregate) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 639310afc..5e8008999 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -224,6 +224,11 @@ 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_1 "fold_op" + (e_set [ e_int 4 ; e_int 10 ]) + (e_int 29) + in ok () let unit_expression () : unit result = @@ -352,6 +357,15 @@ let moption () : unit result = in ok () +let mmap () : unit result = + let%bind program = mtype_file "./contracts/map.mligo" in + let%bind () = expect_eq_evaluate program "foobar" + (e_annotation (e_map []) (t_map t_int t_int)) in + let%bind () = expect_eq_evaluate program "foobarz" + (e_annotation (e_map [(e_int 1 , e_int 10) ; (e_int 2 , e_int 20)]) (t_map t_int t_int)) in + let%bind () = expect_eq_evaluate program "foo" (e_int 10) in + ok () + let map () : unit result = let%bind program = type_file "./contracts/map.ligo" in let ez lst = @@ -386,6 +400,11 @@ let map () : unit result = let make_expected = fun _ -> e_some @@ e_int 4 in expect_eq_n program "get" make_input make_expected in + let%bind () = + let make_input = fun n -> ez [(23, n) ; (42, 4)] in + let make_expected = fun _ -> e_some @@ e_int 4 in + expect_eq_n program "get_" make_input make_expected + in let%bind () = let expected = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in expect_eq_evaluate program "bm" expected @@ -400,6 +419,11 @@ let map () : unit result = let expected = e_int 66 in expect_eq program "iter_op" input expected in + let%bind () = + let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in + let expected = e_int 76 in + expect_eq program "fold_op" input expected + in let%bind () = let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in let expected = ez [(1 , 11) ; (2 , 21) ; (3 , 31) ] in @@ -674,6 +698,8 @@ let match_matej () : unit result = let mligo_list () : unit result = let%bind program = mtype_file "./contracts/list.mligo" in + let aux lst = e_list @@ List.map e_int lst in + let%bind () = expect_eq program "fold_op" (aux [ 1 ; 2 ; 3 ]) (e_int 16) in let%bind () = let make_input n = e_pair (e_list [e_int n; e_int (2*n)]) @@ -687,6 +713,8 @@ let mligo_list () : unit result = let%bind () = expect_eq_evaluate program "x" (e_list []) in let%bind () = expect_eq_evaluate program "y" (e_list @@ List.map e_int [3 ; 4 ; 5]) in let%bind () = expect_eq_evaluate program "z" (e_list @@ List.map e_int [2 ; 3 ; 4 ; 5]) in + let%bind () = expect_eq program "map_op" (aux [2 ; 3 ; 4 ; 5]) (aux [3 ; 4 ; 5 ; 6]) in + let%bind () = expect_eq program "iter_op" (aux [2 ; 3 ; 4 ; 5]) (e_unit ()) in ok () let lambda_mligo () : unit result = @@ -752,6 +780,7 @@ let main = test_suite "Integration (End to End)" [ test "option" option ; test "option (mligo)" moption ; test "map" map ; + test "map (mligo)" mmap ; test "big_map" big_map ; test "list" list ; test "loop" loop ;