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

Merge branch 'fix/various-gitlab-issues' into 'dev'

Browse Source 
Fix/various gitlab issues

See merge request ligolang/ligo!82
This commit is contained in:
Gabriel Alfour 2019-09-24 16:25:40 +00:00
commit 9053a74999
30 changed files with 308 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/main/compile/helpers.ml
View File

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

2
src/passes/2-simplify/ligodity.ml
View File

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

2
src/passes/2-simplify/pascaligo.ml
View File

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

53
src/passes/3-self_ast_simplified/literals.ml Normal file
View File

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

26
src/passes/3-self_ast_simplified/self_ast_simplified.ml
View File

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

6
src/passes/4-typer/typer.ml
View File

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

77
src/passes/6-transpiler/transpiler.ml
View File

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

4
src/passes/6-transpiler/untranspiler.ml
View File

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

16
src/passes/8-compiler/compiler_program.ml
View File

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

2
src/passes/8-compiler/uncompiler.ml
View File

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

2
src/passes/operators/helpers.ml
View File

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

88
src/passes/operators/operators.ml
View File

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

2
src/stages/ast_simplified/PP.ml
View File

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

7
src/stages/ast_simplified/combinators.ml
View File

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

6
src/stages/ast_simplified/misc.ml
View File

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

2
src/stages/ast_simplified/types.ml
View File

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

2
src/stages/ast_typed/PP.ml
View File

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

4
src/stages/ast_typed/combinators.ml
View File

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

2
src/stages/ast_typed/combinators_environment.ml
View File

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

6
src/stages/ast_typed/misc.ml
View File

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

2
src/stages/ast_typed/types.ml
View File

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

4
src/stages/mini_c/PP.ml
View File

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

4
src/stages/mini_c/combinators.ml
View File

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

3
src/stages/mini_c/types.ml
View File

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

2
src/test/coase_tests.ml
View File

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

12
src/test/contracts/list.mligo
View File

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

9
src/test/contracts/map.ligo
View File

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

7
src/test/contracts/map.mligo Normal file
View File

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

5
src/test/contracts/set_arithmetic-1.ligo
View File

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

29
src/test/integration_tests.ml
View File

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