diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index cd736ba51..14ee17375 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -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) {@; @[%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) -> diff --git a/src/ligo/mini_c/PP.ml b/src/ligo/mini_c/PP.ml index 8e3d0e630..eb9da3678 100644 --- a/src/ligo/mini_c/PP.ml +++ b/src/ligo/mini_c/PP.ml @@ -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) -> diff --git a/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml index 7304be3ed..5ad13b239 100644 --- a/src/ligo/mini_c/combinators.ml +++ b/src/ligo/mini_c/combinators.ml @@ -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 = diff --git a/src/ligo/mini_c/compiler.ml b/src/ligo/mini_c/compiler.ml index 13ce7e4c1..eaed834dc 100644 --- a/src/ligo/mini_c/compiler.ml +++ b/src/ligo/mini_c/compiler.ml @@ -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) -> diff --git a/src/ligo/mini_c/compiler_environment.ml b/src/ligo/mini_c/compiler_environment.ml index f8987dc97..ef6a34d7b 100644 --- a/src/ligo/mini_c/compiler_environment.ml +++ b/src/ligo/mini_c/compiler_environment.ml @@ -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) diff --git a/src/ligo/mini_c/types.ml b/src/ligo/mini_c/types.ml index fb1d8bf1c..cb5104db7 100644 --- a/src/ligo/mini_c/types.ml +++ b/src/ligo/mini_c/types.ml @@ -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 diff --git a/src/ligo/test/compiler_tests.ml b/src/ligo/test/compiler_tests.ml index 6f97a7df6..3d0176410 100644 --- a/src/ligo/test/compiler_tests.ml +++ b/src/ligo/test/compiler_tests.ml @@ -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 diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index e21c68f45..5fe92c182 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -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 diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index 074afc7a2..fb28635c9 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -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}