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

separate declaration from assignment at mini_c and ast_typed level

Browse Source
This commit is contained in:
Galfour 2019-04-15 07:23:41 +00:00
parent 68f37e14aa
commit 0522d922c2
9 changed files with 71 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/ligo/ast_typed.ml
View File

@ -90,6 +90,7 @@ and block = instruction list
and b = block
and instruction =
| I_declaration of named_expression
| I_assignment of named_expression
| I_matching of ae * matching_instr
| I_loop of ae * b
@ -227,6 +228,8 @@ module PP = struct
| I_skip -> fprintf ppf "skip"
| I_fail ae -> fprintf ppf "fail with (%a)" annotated_expression ae
| I_loop (cond, b) -> fprintf ppf "while (%a) {@; @[<v>%a@]@;}" annotated_expression cond block b
| I_declaration {name;annotated_expression = ae} ->
fprintf ppf "let %s = %a" name annotated_expression ae
| I_assignment {name;annotated_expression = ae} ->
fprintf ppf "%s := %a" name annotated_expression ae
| I_matching (ae, m) ->

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

@ -87,9 +87,12 @@ and function_ ppf ({binder ; input ; output ; body ; result ; capture_type}:anon
block body
expression result
and assignment ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expression e
and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e
and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expression e
and statement ppf ((s, _) : statement) = match s with
| 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) ->

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

@ -113,6 +113,7 @@ let statement s' e : statement =
| S_if_none _ -> s', id_environment_wrap e
| S_while _ -> s', id_environment_wrap e
| S_patch _ -> s', id_environment_wrap e
| S_declaration (name, (_, t, _)) -> s', environment_wrap e (Compiler_environment.add (name, t) e)
| S_assignment (name, (_, t, _)) -> s', environment_wrap e (Compiler_environment.add (name, t) e)
let block (statements:statement list) : block result =

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

@ -291,13 +291,23 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
let error_message () = Format.asprintf "%a" PP.statement s in
let%bind (code : michelson) =
trace (fun () -> error (thunk "translating statement") error_message ()) @@ match s' with
| S_assignment (s, ((_, tv, _) as expr)) ->
| S_declaration (s, ((_, tv, _) as expr)) ->
let%bind expr = translate_expression expr in
let%bind add =
if Environment.has s w_env.pre_environment
then Environment.to_michelson_set s w_env.pre_environment
else Environment.to_michelson_add (s, tv) w_env.pre_environment
in
let%bind add = Environment.to_michelson_add (s, tv) w_env.pre_environment in
ok (seq [
i_comment "declaration" ;
seq [
i_comment "expr" ;
i_push_unit ; expr ; i_car ;
] ;
seq [
i_comment "env <- env . expr" ;
add ;
];
])
| S_assignment (s, expr) ->
let%bind expr = translate_expression expr in
let%bind set = Environment.to_michelson_set s w_env.pre_environment in
ok (seq [
i_comment "assignment" ;
seq [
@ -306,7 +316,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
] ;
seq [
i_comment "env <- env . expr" ;
add ;
set ;
];
])
| S_cond (expr, a, b) ->

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

@ -13,6 +13,25 @@ module Small = struct
type t' = environment_small'
type t = environment_small
let not_in_env' ?source s t' =
let title () = match source with
| None -> "Not in environment"
| Some source -> Format.asprintf "Not in environment' (%s)" source in
let content () =
Format.asprintf "Variable : %s, Environment' : %a"
s PP.environment_small' t' in
error title content
let not_in_env ?source s t =
let title () = match source with
| None -> "Not in environment"
| Some source -> Format.asprintf "Not in environment (%s)" source in
let content () =
Format.asprintf "Variable : %s, Environment : %a"
s PP.environment_small t in
error title content
let has' s = exists' (fun ((x, _):element) -> x = s)
let has s = function
| Empty -> false
@ -49,7 +68,7 @@ module Small = struct
let rec get_path' = fun s env' ->
match env' with
| Leaf (n, v) when n = s -> ok ([], v)
| Leaf _ -> simple_fail "Not in env"
| Leaf _ -> fail @@ not_in_env' ~source:"get_path'" s env'
| Node {a;b} ->
match%bind bind_lr @@ Tezos_utils.Tuple.map2 (get_path' s) (a,b) with
| `Left (lst, v) -> ok ((`Left :: lst), v)
@ -57,12 +76,13 @@ module Small = struct
let get_path = fun s env ->
match env with
| Empty -> simple_fail "Set : No env"
| Empty -> fail @@ not_in_env ~source:"get_path" s env
| Full x -> get_path' s x
let rec to_michelson_get' s = function
let rec to_michelson_get' = fun s env' ->
match env' with
| Leaf (n, tv) when n = s -> ok @@ (seq [], tv)
| Leaf _ -> simple_fail "Schema.Small.get : not in env"
| Leaf _ -> fail @@ not_in_env' ~source:"to_michelson_get'" s env'
| Node {a;b} -> (
match%bind bind_lr @@ Tezos_utils.Tuple.map2 (to_michelson_get' s) (a, b) with
| `Left (x, tv) -> ok @@ (seq [i_car ; x], tv)
@ -72,9 +92,10 @@ module Small = struct
| Empty -> simple_fail "Schema.Small.get : not in env"
| Full x -> to_michelson_get' s x
let rec to_michelson_set' s = function
let rec to_michelson_set' = fun s env' ->
match env' with
| Leaf (n, tv) when n = s -> ok (dip i_drop, tv)
| Leaf _ -> simple_fail "Schema.Small.set : not in env"
| Leaf _ -> fail @@ not_in_env' ~source:"Small.to_michelson_set'" s env'
| Node {a;b} -> (
match%bind bind_lr @@ Tezos_utils.Tuple.map2 (to_michelson_set' s) (a, b) with
| `Left (x, tv) -> ok (seq [dip i_unpair ; x ; i_pair], tv)

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

@ -70,6 +70,7 @@ and expression = expression' * type_value * environment (* Environment in which
and assignment = var_name * expression
and statement' =
| S_declaration of assignment (* First assignment *)
| S_assignment of assignment
| S_cond of expression * block * block
| S_patch of string * [`Left | `Right] list * expression

10
src/ligo/test/compiler_tests.ml
View File

@ -12,7 +12,7 @@ let run_entry_int (e:anon_function) (n:int) : int result =
let identity () : unit result =
let e = basic_int_quote_env in
let s = statement (S_assignment ("output", e_var_int "input" e)) e in
let s = statement (S_declaration ("output", e_var_int "input" e)) e in
let%bind b = block [s] in
let%bind f = basic_int_quote b in
let%bind result = run_entry_int f 42 in
@ -27,10 +27,10 @@ let multiple_vars () : unit result =
Yes. One could do a monad. Feel free when we have the time.
*)
let ss = statements [
(fun e -> statement (S_assignment ("a", e_var_int "input" e)) e) ;
(fun e -> statement (S_assignment ("b", e_var_int "input" e)) e) ;
(fun e -> statement (S_assignment ("c", e_var_int "a" e)) e) ;
(fun e -> statement (S_assignment ("output", e_var_int "c" e)) e) ;
(fun e -> statement (S_declaration ("a", e_var_int "input" e)) e) ;
(fun e -> statement (S_declaration ("b", e_var_int "input" e)) e) ;
(fun e -> statement (S_declaration ("c", e_var_int "a" e)) e) ;
(fun e -> statement (S_declaration ("output", e_var_int "c" e)) e) ;
] e in
let%bind b = block ss in
let%bind f = basic_int_quote b in

14
src/ligo/transpiler.ml
View File

@ -120,13 +120,13 @@ let rec translate_block env (b:AST.block) : block result =
and translate_instruction (env:Environment.t) (i:AST.instruction) : statement option result =
let return ?(env' = env) x : statement option result = ok (Some (x, environment_wrap env env')) in
match i with
| I_assignment {name;annotated_expression} ->
| I_declaration {name;annotated_expression} ->
let%bind (_, t, _) as expression = translate_annotated_expression env annotated_expression in
let env' =
match Environment.has name env with
| true -> env
| false -> Environment.add (name, t) env in
return ~env' (S_assignment (name, expression))
let env' = Environment.add (name, t) env in
return ~env' (S_declaration (name, expression))
| I_assignment {name;annotated_expression} ->
let%bind expression = translate_annotated_expression env annotated_expression in
return (S_assignment (name, expression))
| I_patch (r, s, v) -> (
let ty = r.type_value in
let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result =
@ -424,7 +424,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
let (a, b) = functionalize an.annotated_expression in
Some (acc, a, b)
) else (
aux ((AST.I_assignment an) :: acc) tl
aux ((AST.I_declaration an) :: acc) tl
)
)
in

10
src/ligo/typer.ml
View File

@ -148,17 +148,16 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
return @@ O.I_loop (cond, body)
| I_assignment {name;annotated_expression} -> (
match annotated_expression.type_annotation, Environment.get e name with
| None, None -> simple_fail "Initial assignments need type"
| None, None -> simple_fail "Initial assignments need type annotation"
| Some _, None ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let e' = Environment.add e name annotated_expression.type_annotation in
ok (e', [O.I_assignment {name;annotated_expression}])
ok (e', [O.I_declaration {name;annotated_expression}])
| None, Some prev ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let e' = Environment.add e name annotated_expression.type_annotation in
let%bind _ =
O.assert_type_value_eq (annotated_expression.type_annotation, prev) in
ok (e', [O.I_assignment {name;annotated_expression}])
ok (e, [O.I_assignment {name;annotated_expression}])
| Some _, Some prev ->
let%bind annotated_expression = type_annotated_expression e annotated_expression in
let%bind _assert = trace (simple_error "Annotation doesn't match environment")
@ -588,6 +587,9 @@ and untype_instruction (i:O.instruction) : (I.instruction) result =
let%bind e' = untype_annotated_expression e in
let%bind b' = untype_block b in
ok @@ I_loop (e', b')
| I_declaration a ->
let%bind annotated_expression = untype_annotated_expression a.annotated_expression in
ok @@ I_assignment {name = a.name ; annotated_expression}
| I_assignment a ->
let%bind annotated_expression = untype_annotated_expression a.annotated_expression in
ok @@ I_assignment {name = a.name ; annotated_expression}