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

selection of environment can be done both ways

Browse Source
This commit is contained in:
galfour 2019-07-18 13:04:13 +02:00
parent 68014c6e95
commit 25566bc3fe
7 changed files with 53 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/compiler/compiler_environment.ml
View File

@ -87,7 +87,7 @@ let add : environment -> (string * type_value) -> michelson result = fun e (_s ,
ok code
let select : environment -> string list -> michelson result = fun e lst ->
let select ?(rev = false) : environment -> string list -> michelson result = fun e lst ->
let module L = Logger.Stateful() in
let e_lst =
let e_lst = Environment.to_list e in
@ -96,7 +96,11 @@ let select : environment -> string list -> michelson result = fun e lst ->
match List.mem s selector with
| true -> List.remove_element s selector , true
| false -> selector , false in
let e_lst' = List.fold_map_right aux lst e_lst in
let e_lst' =
if rev
then List.fold_map aux lst e_lst
else List.fold_map_right aux lst e_lst
in
let e_lst'' = List.combine e_lst e_lst' in
e_lst'' in
let code =
@ -145,7 +149,7 @@ let clear : environment -> (michelson * environment) result = fun e ->
trace_option (simple_error "try to clear empty env") @@
List.nth_opt lst 0 in
let%bind code = select e [ first_name ] in
let e' = Environment.select [ first_name ] e in
let e' = Environment.select ~rev:true [ first_name ] e in
ok (code , e')
let pack : environment -> michelson result = fun e ->

36
src/compiler/compiler_program.ml
View File

@ -106,11 +106,14 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
let return ?prepend_env ?end_env code =
let%bind env' =
match (prepend_env , end_env) with
| (Some _ , Some _) -> simple_fail ("two args to return at " ^ __LOC__)
| None , None -> ok @@ Environment.add ("_tmp_expression" , ty) env
| (Some _ , Some _) ->
simple_fail ("two args to return at " ^ __LOC__)
| None , None ->
ok @@ Environment.add ("_tmp_expression" , ty) env
| Some prepend_env , None ->
ok @@ Environment.add ("_tmp_expression" , ty) prepend_env
| None , Some end_env -> ok end_env in
| None , Some end_env ->
ok end_env in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in
let%bind output_type = Compiler_type.type_ ty in
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in
@ -152,6 +155,11 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
unpack ;
i_skip ;
]
(* return ~end_env:load_env @@ seq [
* expr' ;
* dip clear ;
* unpack ;
* ] *)
| E_environment_select sub_env ->
let%bind code = Compiler_environment.select_env env sub_env in
return ~prepend_env:sub_env @@ seq [
@ -161,6 +169,8 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
| E_environment_return expr -> (
let%bind (expr' , env) = translate_expression expr env in
let%bind (code , cleared_env) = Compiler_environment.clear env in
Format.printf "pre env %a\n" PP.environment env ;
Format.printf "post clean env %a\n" PP.environment cleared_env ;
return ~end_env:cleared_env @@ seq [
expr' ;
code ;
@ -221,7 +231,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
| E_variable x ->
let%bind code = Compiler_environment.get env x in
return code
| E_sequence (a , b) ->
| E_sequence (a , b) -> (
let%bind (a' , env_a) = translate_expression a env in
let%bind env_a' = Compiler_environment.pop env_a in
let%bind (b' , env_b) = translate_expression b env_a' in
@ -230,6 +240,13 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
i_drop ;
b' ;
]
(* let%bind (a' , env_a) = translate_expression a env in
* let%bind (b' , env_b) = translate_expression b env_a in
* return ~end_env:env_b @@ seq [
* a' ;
* b' ;
* ] *)
)
| E_constant(str, lst) ->
let module L = Logger.Stateful() in
let%bind lst' =
@ -313,9 +330,9 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
| E_if_left (c, (l_ntv , l), (r_ntv , r)) -> (
let%bind (c' , _env') = translate_expression c env in
let l_env = Environment.add l_ntv env in
let%bind (l' , _) = translate_expression l l_env in
let%bind (l' , _l_env') = translate_expression l l_env in
let r_env = Environment.add r_ntv env in
let%bind (r' , _) = translate_expression r r_env in
let%bind (r' , _r_env') = translate_expression r r_env in
let%bind restrict_l = Compiler_environment.select_env l_env env in
let%bind restrict_r = Compiler_environment.select_env r_env env in
let%bind code = ok (seq [
@ -406,7 +423,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
and translate_quote_body ({result ; binder ; input} as f:anon_function) : michelson result =
let env = Environment.(add (binder , input) empty) in
let%bind (expr , _) = translate_expression result env in
let%bind (expr , env') = translate_expression result env in
let code = seq [
i_comment "function result" ;
expr ;
@ -419,10 +436,13 @@ and translate_quote_body ({result ; binder ; input} as f:anon_function) : michel
let output_stack_ty = Stack.(output_ty @: nil) in
let error_message () =
Format.asprintf
"\ncode : %a\ninput : %a\noutput : %a\n"
"\nCode : %a\nMichelson code : %a\ninput : %a\noutput : %a\nstart env : %a\nend env : %a\n"
PP.expression result
Michelson.pp code
PP.type_ f.input
PP.type_ f.output
PP.environment env
PP.environment env'
in
let%bind _ =
Trace.trace_tzresult_lwt (

4
src/compiler/compiler_type.ml
View File

@ -10,12 +10,14 @@ module Contract_types = Meta_michelson.Types
module Ty = struct
let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
let comparable_type_base : type_base -> ex_comparable_ty result = fun tb ->
let open Contract_types in
let return x = ok @@ Ex_comparable_ty x in
match tb with
| Base_unit -> fail (not_comparable "unit")
| Base_void -> fail (not_comparable "void")
| Base_bool -> fail (not_comparable "bool")
| Base_nat -> return nat_k
| Base_tez -> return tez_k
@ -44,6 +46,7 @@ module Ty = struct
let return x = ok @@ Ex_ty x in
match b with
| Base_unit -> return unit
| Base_void -> fail (not_compilable_type "void")
| Base_bool -> return bool
| Base_int -> return int
| Base_nat -> return nat
@ -118,6 +121,7 @@ end
let base_type : type_base -> O.michelson result =
function
| Base_unit -> ok @@ O.prim T_unit
| Base_void -> fail (Ty.not_compilable_type "void")
| Base_bool -> ok @@ O.prim T_bool
| Base_int -> ok @@ O.prim T_int
| Base_nat -> ok @@ O.prim T_nat

12
src/mini_c/PP.ml
View File

@ -10,6 +10,7 @@ let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R
let type_base ppf : type_base -> _ = function
| Base_unit -> fprintf ppf "unit"
| Base_void -> fprintf ppf "void"
| Base_bool -> fprintf ppf "bool"
| Base_int -> fprintf ppf "int"
| Base_nat -> fprintf ppf "nat"
@ -48,7 +49,7 @@ let rec value ppf : value -> unit = function
| D_nat n -> fprintf ppf "+%d" n
| D_timestamp n -> fprintf ppf "+%d" n
| D_tez n -> fprintf ppf "%dtz" n
| D_unit -> fprintf ppf " "
| D_unit -> fprintf ppf "unit"
| D_string s -> fprintf ppf "\"%s\"" s
| D_bytes _ -> fprintf ppf "[bytes]"
| D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b
@ -68,12 +69,12 @@ and expression' ppf (e:expression') = match e with
| E_environment_capture s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s
| E_environment_load (expr , env) -> fprintf ppf "load %a in %a" expression expr environment env
| E_environment_select env -> fprintf ppf "select %a" environment env
| E_environment_return expr -> fprintf ppf "return %a" expression expr
| E_environment_return expr -> fprintf ppf "return (%a)" expression expr
| E_skip -> fprintf ppf "skip"
| E_variable v -> fprintf ppf "%s" v
| E_variable v -> fprintf ppf "V(%s)" v
| E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b
| E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst
| E_literal v -> fprintf ppf "%a" value v
| E_literal v -> fprintf ppf "L(%a)" value v
| E_make_empty_map _ -> fprintf ppf "map[]"
| E_make_empty_list _ -> fprintf ppf "list[]"
| E_make_empty_set _ -> fprintf ppf "set[]"
@ -82,8 +83,7 @@ and expression' ppf (e:expression') = match e with
| E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s
| E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r
| E_sequence (a , b) -> fprintf ppf "%a ; %a" expression a expression b
(* | E_sequence_drop (a , b) -> fprintf ppf "%a ;- %a" expression a expression b *)
| 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_assignment (r , path , e) ->

8
src/mini_c/environment.ml
View File

@ -32,14 +32,18 @@ module Environment (* : ENVIRONMENT *) = struct
let get_names : t -> string list = List.map fst
let remove : int -> t -> t = List.remove
let select : string list -> t -> t = fun lst env ->
let select ?(rev = false) : string list -> t -> t = fun lst env ->
let e_lst =
let e_lst = to_list env in
let aux selector (s , _) =
match List.mem s selector with
| true -> List.remove_element s selector , true
| false -> selector , false in
let e_lst' = List.fold_map_right aux lst e_lst in
let e_lst' =
if rev
then List.fold_map aux lst e_lst
else List.fold_map_right aux lst e_lst
in
let e_lst'' = List.combine e_lst e_lst' in
e_lst'' in
of_list

2
src/mini_c/types.ml
View File

@ -1,7 +1,7 @@
type type_name = string
type type_base =
| Base_unit
| Base_unit | Base_void
| Base_bool
| Base_int | Base_nat | Base_tez
| Base_timestamp