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

better mini_c instructions

Browse Source
This commit is contained in:
Galfour 2019-04-15 17:42:06 +00:00
parent 5b577c1fa4
commit 126b62b18e
8 changed files with 48 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/ligo/contracts/match.ligo
View File

@ -12,7 +12,7 @@ function match_option (const o : option(int)) : int is
begin
case o of
| None -> skip
| Some(s) -> result := s
| Some(s) -> skip // result := s
end
end with result

3
src/ligo/mini_c/PP.ml
View File

@ -94,13 +94,14 @@ and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expressio
and statement ppf ((s, _) : statement) = match s with
| S_environment_extend -> fprintf ppf "extend"
| S_environment_restrict -> fprintf ppf "restrict"
| S_environment_add (name, tv) -> fprintf ppf "add %s %a" name type_ tv
| S_declaration ass -> declaration ppf ass
| S_assignment ass -> assignment ppf ass
| S_cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e
| S_patch (r, path, e) ->
let aux = fun ppf -> function `Left -> fprintf ppf ".L" | `Right -> fprintf ppf ".R" in
fprintf ppf "%s%a := %a" r (list aux) path expression e
| S_if_none (expr, none, (name, some)) -> fprintf ppf "if_none (%a) %a %s.%a" expression expr block none name block some
| S_if_none (expr, none, ((name, _), some)) -> fprintf ppf "if_none (%a) %a %s->%a" expression expr block none name block some
| S_while (e, b) -> fprintf ppf "while (%a) %a" expression e block b
and block ppf ((b, _):block) =

16
src/ligo/mini_c/combinators.ml
View File

@ -111,6 +111,7 @@ let statement s' e : statement =
match s' with
| S_environment_extend -> s', environment_wrap e (Compiler_environment.extend e)
| S_environment_restrict -> s', environment_wrap e (Compiler_environment.restrict e)
| S_environment_add (name, tv) -> s', environment_wrap e (Compiler_environment.add (name, tv) e)
| S_cond _ -> s', id_environment_wrap e
| S_if_none _ -> s', id_environment_wrap e
| S_while _ -> s', id_environment_wrap e
@ -126,6 +127,21 @@ let block (statements:statement list) : block result =
let last = List.(nth lst (length lst - 1)) in
ok (lst, environment_wrap (snd first).pre_environment (snd last).post_environment)
let append_statement' : block -> statement' -> block = fun b s' ->
let b_wrap = snd b in
let s = statement s' b_wrap.post_environment in
let s_wrap = snd s in
let b_wrap' = { b_wrap with post_environment = s_wrap.post_environment } in
let b_content = fst b in
(b_content @ [s], b_wrap')
let prepend_statement : statement -> block -> block = fun s b ->
let s_wrap = snd s in
let b_wrap = snd b in
let b_wrap' = { b_wrap with pre_environment = s_wrap.pre_environment } in
let b_content = fst b in
(s :: b_content, b_wrap')
let statements (lst:(environment -> statement) list) e : statement list =
let rec aux lst e = match lst with
| [] -> []

14
src/ligo/mini_c/compiler.ml
View File

@ -295,6 +295,10 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
ok @@ Environment.to_michelson_extend w_env.pre_environment
| S_environment_restrict ->
Environment.to_michelson_restrict w_env.pre_environment
| S_environment_add _ ->
simple_fail "not ready yet"
(* | S_environment_add (name, tv) ->
* Environment.to_michelson_add (name, tv) w_env.pre_environment *)
| S_declaration (s, ((_, tv, _) as expr)) ->
let%bind expr = translate_expression expr in
let%bind add = Environment.to_michelson_add (s, tv) w_env.pre_environment in
@ -331,19 +335,17 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
i_push_unit ;
expr ;
prim I_CAR ;
dip @@ Environment.to_michelson_extend w_env.pre_environment ;
prim ~children:[seq [a'];seq [b']] I_IF ;
])
| S_if_none (expr, none, (_, some)) ->
| S_if_none (expr, none, ((name, tv), some)) ->
let%bind expr = translate_expression expr in
let%bind none' = translate_regular_block none in
let%bind some' = translate_regular_block some in
let%bind add =
let env = Environment.extend w_env.pre_environment in
Environment.to_michelson_anonymous_add env in
let env' = Environment.extend w_env.pre_environment in
Environment.to_michelson_add (name, tv) env' in
ok @@ (seq [
i_push_unit ; expr ; i_car ;
dip @@ Environment.to_michelson_extend w_env.pre_environment ;
prim ~children:[
seq [none'] ;
seq [add ; some'] ;
@ -383,7 +385,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
let%bind pre_env_michelson = Environment.to_michelson_type w_env.pre_environment in
let%bind post_env_michelson = Environment.to_michelson_type w_env.post_environment in
ok @@ Format.asprintf
"statement : %a\ncode : %a\npre type : %a\npost type : %a"
"statement : %a\ncode : %a\npre type : %a\npost type : %a\n"
PP.statement s
Michelson.pp code
Michelson.pp pre_env_michelson

49
src/ligo/mini_c/compiler_environment.ml
View File

@ -173,7 +173,7 @@ let to_michelson_restrict : t -> Michelson.t result = fun e ->
match e with
| [] -> simple_fail "Restrict empty env"
| Empty :: _ -> ok @@ Michelson.i_comment "restrict empty"
| _ -> ok @@ Michelson.i_cdr
| _ -> ok @@ Michelson.(seq [i_comment "restrict" ; i_cdr])
(* Michelson.i_cdr *)
let to_ty = Compiler_type.Ty.environment
@ -225,25 +225,19 @@ let path_to_michelson_set = fun path ->
let to_michelson_anonymous_add (t:t) =
let%bind code = match t with
| [] -> simple_fail "Schema.Big.Add.to_michelson_add"
| [hd] -> Small.to_michelson_append hd
| Empty :: _ -> ok @@ Michelson.i_pair
| [hd] ->
let%bind small = Small.to_michelson_append hd in
ok Michelson.(seq [i_comment "big.small add" ; small])
| Empty :: _ -> ok @@ Michelson.(seq [i_comment "empty_add" ; i_pair])
| hd :: _ -> (
let%bind code = Small.to_michelson_append hd in
ok @@ Michelson.(seq [dip i_unpair ; code ; i_pair])
ok @@ Michelson.(seq [i_comment "big add" ; dip i_unpair ; code ; i_pair])
)
in
ok code
let to_michelson_add x (t:t) =
let%bind code = match t with
| [] -> simple_fail "Schema.Big.Add.to_michelson_add"
| [hd] -> Small.to_michelson_append hd
| Empty :: _ -> ok @@ Michelson.i_pair
| hd :: _ -> (
let%bind code = Small.to_michelson_append hd in
ok @@ Michelson.(seq [dip i_unpair ; code ; i_pair])
)
in
let%bind code = to_michelson_anonymous_add t in
let%bind _assert_type =
let new_schema = add x t in
@ -267,20 +261,6 @@ let to_michelson_add x (t:t) =
ok code
let to_michelson_get (s:t) str : (Michelson.t * type_value) result =
(* let open Michelson in
* let rec aux s str : (Michelson.t * type_value) result = match s with
* | [] -> simple_fail "Schema.Big.get"
* | [a] -> Small.to_michelson_get str a
* | a :: b -> (
* match Small.to_michelson_get str a with
* | Trace.Ok (code, tv) -> ok (seq [i_car ; code], tv)
* | Errors _ ->
* let%bind (code, tv) = aux b str in
* ok (seq [i_cdr ; code], tv)
* )
* in
* let%bind (code, tv) = aux s str in *)
let%bind (path, tv) = get_path str s in
let code = path_to_michelson_get path in
@ -307,21 +287,6 @@ let to_michelson_get (s:t) str : (Michelson.t * type_value) result =
ok (code, tv)
let to_michelson_set str (s:t) : Michelson.t result =
(* let open Michelson in
* let rec aux s str : (Michelson.t * type_value) result =
* match s with
* | [] -> simple_fail "Schema.Big.get"
* | [a] -> Small.to_michelson_set str a
* | a :: b -> (
* match Small.to_michelson_set str a with
* | Trace.Ok (code, tv) -> ok (seq [dip i_unpair ; code ; i_pair], tv)
* | Errors _ ->
* let%bind (tmp, tv) = aux b str in
* ok (seq [dip i_unpiar ; tmp ; i_piar], tv)
* )
* in
* let%bind (code, tv) = aux s str in *)
let%bind (path, tv) = get_path str s in
let code = path_to_michelson_set path in

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

@ -72,11 +72,12 @@ and assignment = var_name * expression
and statement' =
| S_environment_extend
| S_environment_restrict
| S_environment_add of (var_name * type_value)
| S_declaration of assignment (* First assignment *)
| S_assignment of assignment
| S_cond of expression * block * block
| S_patch of string * [`Left | `Right] list * expression
| S_if_none of expression * block * (var_name * block)
| S_if_none of expression * block * ((var_name * type_value) * block)
| S_while of expression * block
and statement = statement' * environment_wrap

3
src/ligo/test/integration_tests.ml
View File

@ -404,7 +404,8 @@ let matching () : unit result =
let%bind result' =
trace (simple_error "bad result") @@
get_a_int result in
Assert.assert_equal_int (match n with None -> 23 | Some s -> s) result'
Assert.assert_equal_int 23 result'
(* Assert.assert_equal_int (match n with None -> 23 | Some s -> s) result' *)
in
let%bind _ = bind_list
@@ List.map aux

23
src/ligo/transpiler.ml
View File

@ -147,27 +147,24 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
| I_matching (expr, m) -> (
let%bind expr' = translate_annotated_expression env expr in
let env' = Environment.extend env in
let aux : block -> block = fun (lst, wrap) -> (* Takes a block and add a "restrict" statement at its end *)
let b_wrap = { wrap with post_environment = env } in
let s_wrap = {
pre_environment = wrap.post_environment ;
post_environment = env ;
} in
(lst @ [S_environment_restrict, s_wrap], b_wrap)
in
let extend s =
let pre = Combinators.statement S_environment_extend env in
ok [ pre ; (s, environment_wrap env env) ] in
let restrict : block -> block = fun b -> Combinators.append_statement' b S_environment_restrict in
match m with
| Match_bool {match_true ; match_false} -> (
let%bind true_branch = translate_block env' match_true in
let%bind false_branch = translate_block env' match_false in
return (S_cond (expr', aux true_branch, aux false_branch))
extend @@ S_cond (expr', restrict true_branch, restrict false_branch)
)
| Match_option {match_none ; match_some = ((name, t), sm)} -> (
let%bind none_branch = translate_block env' match_none in
let%bind t' = translate_type t in
let%bind some_branch =
let%bind t' = translate_type t in
let env' = Environment.add (name, t') env' in
translate_block env' sm in
return (S_if_none (expr', aux none_branch, (name, aux some_branch)))
let env'' = Environment.add (name, t') env' in
translate_block env'' sm
in
extend (S_if_none (expr', restrict none_branch, ((name, t'), restrict some_branch)))
)
| _ -> simple_fail "todo : match"
)