back on track

src/bin/cli.ml

@@ -51,7 +51,7 @@ let compile_file =
     let%bind contract =
       trace (simple_info "compiling contract to michelson") @@
       Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in
-    Format.printf "%a\n" Tezos_utils.Michelson.pp contract ;
+    Format.printf "%a\n" Tezos_utils.Michelson.pp contract.body ;
     ok ()
   in
   let term =

src/main/compile/of_mini_c.ml

@@ -5,11 +5,35 @@ open Tezos_utils
 let compile_value : value -> type_value -> Michelson.t result =
   Compiler.Program.translate_value
 
-let compile_expression : expression -> Michelson.t result = fun e ->
+let compile_expression : expression -> _ result = fun e ->
   Compiler.Program.translate_expression e Compiler.Environment.empty
 
-let compile_function : anon_function -> type_value -> type_value -> Compiler.Program.compiled_program result = fun f in_ty out_ty ->
+let compile_expression_as_function : expression -> _ result = fun e ->
-  Compiler.Program.translate_entry f (in_ty , out_ty)
+  let (input , output) = t_unit , e.type_value in
+  let%bind body = get_function e in
+  let%bind body = compile_value body (t_function input output) in
+  let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in
+  let open! Compiler.Program in
+  ok { input ; output ; body }
+
+let compile_function = fun e ->
+  let%bind (input , output) = get_t_function e.type_value in
+  let%bind body = get_function e in
+  let%bind body = compile_value body (t_function input output) in
+  let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in
+  let open! Compiler.Program in
+  ok { input ; output ; body }
+
+(* let compile_function : anon_function -> (type_value * type_value) -> Compiler.Program.compiled_program result = fun f io ->
+ *   Compiler.Program.translate_entry f io *)
+
+let compile_expression_as_function_entry = fun program name ->
+  let%bind aggregated = aggregate_entry program name true in
+  compile_function aggregated
+
+let compile_function_entry = fun program name ->
+  let%bind aggregated = aggregate_entry program name false in
+  compile_function aggregated
 
 let uncompile_value : Proto_alpha_utils.Memory_proto_alpha.X.ex_typed_value -> value result = fun x ->
   Compiler.Uncompiler.translate_value x

src/main/compile/of_simplified.ml

@@ -2,13 +2,13 @@ open Ast_simplified
 open Trace
 open Tezos_utils
 
-let compile_function_entry (program : program) entry_point : Compiler.Program.compiled_program result =
+let compile_function_entry (program : program) entry_point : _ result =
-  let%bind typed_program = Typer.type_program program in
+  let%bind prog_typed = Typer.type_program program in
-  Of_typed.compile_function_entry typed_program entry_point
+  Of_typed.compile_function_entry prog_typed entry_point
 
-let compile_expression_entry (program : program) entry_point : Compiler.Program.compiled_program result =
+let compile_expression_as_function_entry (program : program) entry_point : _ result =
   let%bind typed_program = Typer.type_program program in
-  Of_typed.compile_expression_entry typed_program entry_point
+  Of_typed.compile_expression_as_function_entry typed_program entry_point
 
 let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result =
   let%bind typed = Typer.type_expression env ae in
@@ -16,7 +16,7 @@ let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson.
 
 let uncompile_typed_program_entry_expression_result program entry ex_ty_value =
   let%bind output_type =
-    let%bind (entry_expression , _ ) = Of_typed.get_entry program entry in
+    let%bind entry_expression = Ast_typed.get_entry program entry in
     ok entry_expression.type_annotation
   in
   let%bind typed = Of_typed.uncompile_value ex_ty_value output_type in
@@ -24,7 +24,7 @@ let uncompile_typed_program_entry_expression_result program entry ex_ty_value =
 
 let uncompile_typed_program_entry_function_result program entry ex_ty_value =
   let%bind output_type =
-    let%bind (entry_expression , _ ) = Of_typed.get_entry program entry in
+    let%bind entry_expression = Ast_typed.get_entry program entry in
     let%bind (_ , output_type) = Ast_typed.get_t_function entry_expression.type_annotation in
     ok output_type
   in

src/main/compile/of_source.ml

@@ -7,16 +7,15 @@ let parse_file_program source_filename syntax =
   let%bind simplified = parsify syntax source_filename in
   ok simplified
 
-let compile_file_entry : string -> string -> s_syntax -> Compiler.Program.compiled_program result =
+let compile_file_entry : string -> string -> s_syntax -> _ result =
   fun source_filename entry_point syntax ->
   let%bind simplified = parse_file_program source_filename syntax in
   Of_simplified.compile_function_entry simplified entry_point
 
-let compile_file_contract_entry : string -> string -> s_syntax -> Michelson.t result =
+let compile_file_contract_entry : string -> string -> s_syntax -> _ result =
   fun source_filename entry_point syntax ->
   let%bind simplified = parse_file_program source_filename syntax in
-  let%bind f = Of_simplified.compile_function_entry simplified entry_point in
+  Of_simplified.compile_function_entry simplified entry_point
-  ok f.body
 
 let compile_file_contract_parameter : string -> string -> string -> s_syntax -> Michelson.t result =
   fun source_filename _entry_point expression syntax ->

src/main/compile/of_typed.ml

@@ -2,37 +2,21 @@ open Trace
 open Ast_typed
 open Tezos_utils
 
-module Errors = struct
-
-  let missing_entry_point name =
-    let title () = "missing entry point" in
-    let content () = "no entry point with the given name" in
-    let data = [
-      ("name" , fun () -> name) ;
-    ] in
-    error ~data title content
-
-  let not_functional_main location =
-    let title () = "not functional main" in
-    let content () = "main should be a function" in
-    let data = [
-      ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
-    ] in
-    error ~data title content
-
-end
-
-(*
-   This converts `expr` in `fun () -> expr`.
-*)
-let functionalize (body : annotated_expression) : annotated_expression =
-  let expression = E_lambda { binder = "_" ; body } in
-  let type_annotation = t_function (t_unit ()) body.type_annotation () in
-  { body with expression ; type_annotation }
 
 let compile_expression : annotated_expression -> Michelson.t result = fun e ->
   let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in
-  Of_mini_c.compile_expression mini_c_expression
+  let%bind expr = Of_mini_c.compile_expression mini_c_expression in
+  ok expr
+
+let compile_expression_as_function : annotated_expression -> _ result = fun e ->
+  let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in
+  let%bind expr = Of_mini_c.compile_expression_as_function mini_c_expression in
+  ok expr
+
+let compile_function : annotated_expression -> _ result = fun e ->
+  let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in
+  let%bind expr = Of_mini_c.compile_function mini_c_expression in
+  ok expr
 
 (*
    val compile_value : annotated_expression -> Michelson.t result
@@ -40,102 +24,22 @@ let compile_expression : annotated_expression -> Michelson.t result = fun e ->
    `transpile_expression_as_value : annotated_expression -> Mini_c.value result`
  *)
 
-let compile_function expr =
-  let%bind l = get_lambda expr.expression in
-  let%bind io = get_t_function expr.type_annotation in
-  let%bind mini_c = Transpiler.transpile_lambda Mini_c.Environment.empty l io in
-  let%bind (f , (in_ty , out_ty)) =
-    match (mini_c.content , mini_c.type_value) with
-    | E_literal (D_function f) , T_function ty -> ok (f , ty)
-    | _ -> fail @@ Errors.not_functional_main expr.location
-  in
-  Of_mini_c.compile_function f in_ty out_ty
-
-
-let get_entry (lst : program) (name : string) : (annotated_expression * int) result =
-  let%bind entry_expression =
-    trace_option (Errors.missing_entry_point name) @@
-    let aux x =
-      let (Declaration_constant (an , _)) = Location.unwrap x in
-      if (an.name = name)
-      then Some an.annotated_expression
-      else None
-    in
-    List.find_map aux lst
-  in
-  let entry_index =
-    let aux x =
-      let (Declaration_constant (an , _)) = Location.unwrap x in
-      an.name = name
-    in
-    List.find_index aux lst
-  in
-  ok (entry_expression , entry_index)
-
-(*
-   Assume the following code:
-   ```
-     const x = 42
-     const y = 120
-     const z = 423
-     const f = () -> x + y
-   ```
-   It is transformed in:
-   ```
-     const f = () ->
-       let x = 42 in
-       let y = 120 in
-       let z = 423 in
-       x + y
-   ```
-
-   The entry-point can be an expression, which is then functionalized if
-   `to_functionalize` is set to true.
-*)
-let get_aggregated_entry (lst : program) (name : string) (to_functionalize : bool) : annotated_expression result =
-  let%bind (entry_expression , entry_index) = get_entry lst name in
-  let pre_declarations =
-    let sub_program = List.until entry_index lst in
-    let aux x = Location.unwrap x in
-    List.map aux sub_program
-  in
-  let wrapper =
-    let aux prec cur =
-      let (Declaration_constant (an , (pre_env , _))) = cur in
-      e_a_let_in an.name an.annotated_expression prec pre_env
-    in
-    fun expr -> List.fold_right' aux expr pre_declarations
-  in
-  match (entry_expression.expression , to_functionalize) with
-  | (E_lambda l , false) -> (
-      let l' = { l with body = wrapper l.body } in
-      let e' = { entry_expression with expression = E_lambda l' } in
-      ok e'
-    )
-  | (_ , true) -> (
-      ok @@ functionalize @@ wrapper entry_expression
-    )
-  | _ -> fail @@ Errors.not_functional_main entry_expression.location
-
 let compile_function_entry : program -> string -> _ = fun p entry ->
-  let%bind expr = get_aggregated_entry p entry false in
+  let%bind prog_mini_c = Transpiler.transpile_program p in
-  compile_function expr
+  Of_mini_c.compile_function_entry prog_mini_c entry
 
-let compile_expression_entry : program -> string -> _ = fun p entry ->
+let compile_expression_as_function_entry : program -> string -> _ = fun p entry ->
-  let%bind expr = get_aggregated_entry p entry true in
+  let%bind prog_mini_c = Transpiler.transpile_program p in
-  compile_function expr
+  Of_mini_c.compile_expression_as_function_entry prog_mini_c entry
-
-let compile_expression_as_function : annotated_expression -> Compiler.Program.compiled_program result = fun e ->
-  let expr = functionalize e in
-  compile_function expr
 
 let uncompile_value : _ -> _ -> annotated_expression result = fun x ty ->
   let%bind mini_c = Of_mini_c.uncompile_value x in
-  Transpiler.untranspile mini_c ty
+  let%bind typed = Transpiler.untranspile mini_c ty in
+  ok typed
 
 let uncompile_entry_function_result = fun program entry ex_ty_value ->
   let%bind output_type =
-    let%bind (entry_expression , _ ) = get_entry program entry in
+    let%bind entry_expression = get_entry program entry in
     let%bind (_ , output_type) = get_t_function entry_expression.type_annotation in
     ok output_type
   in
@@ -143,7 +47,7 @@ let uncompile_entry_function_result = fun program entry ex_ty_value ->
 
 let uncompile_entry_expression_result = fun program entry ex_ty_value ->
   let%bind output_type =
-    let%bind (entry_expression , _ ) = get_entry program entry in
+    let%bind entry_expression = get_entry program entry in
     ok entry_expression.type_annotation
   in
   uncompile_value ex_ty_value output_type

src/main/run/of_michelson.ml

@@ -13,7 +13,17 @@ let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_t
   let%bind input =
     Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
     Memory_proto_alpha.parse_michelson_data input_michelson input_ty in
-  let body = Michelson.strip_annots body in
+  let body = Michelson.(strip_nops @@ strip_annots body) in
+
+  let%bind input_ty_mich =
+    Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@
+    Memory_proto_alpha.unparse_michelson_ty input_ty in
+  let%bind output_ty_mich =
+    Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@
+    Memory_proto_alpha.unparse_michelson_ty output_ty in
+  Format.printf "code: %a\n" Michelson.pp program.body ;
+  Format.printf "input: %a\n" Michelson.pp input_ty_mich ;
+  Format.printf "output: %a\n" Michelson.pp output_ty_mich ;
   let%bind descr =
     Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
     Memory_proto_alpha.parse_michelson body
@@ -23,3 +33,5 @@ let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_t
     Trace.trace_tzresult_lwt (simple_error "error of execution") @@
     Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
   ok (Ex_typed_value (output_ty, output))
+
+let evaluate ?options program = run ?options program Michelson.d_unit

src/main/run/of_mini_c.ml

@@ -2,7 +2,7 @@ open Proto_alpha_utils
 open Memory_proto_alpha.X
 open Trace
 open Mini_c
-open Compiler.Program
+open! Compiler.Program
 
 module Errors = struct
 
@@ -19,27 +19,29 @@ type options = {
   michelson_options : Of_michelson.options ;
 }
 
-let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (input:value) : value result =
+let evaluate ?options expression =
-  let%bind compiled =
+  let%bind code = Compile.Of_mini_c.compile_expression_as_function expression in
-    trace Errors.entry_error @@
+  let%bind ex_ty_value = Of_michelson.evaluate ?options code in
-    translate_entry entry ty in
+  Compile.Of_mini_c.uncompile_value ex_ty_value
-  let%bind input_michelson = translate_value input (fst ty) in
+
-  if debug_michelson then (
+let evaluate_entry ?options program entry =
-    Format.printf "Program: %a\n" Michelson.pp compiled.body ;
+  let%bind code = Compile.Of_mini_c.compile_expression_as_function_entry program entry in
-    Format.printf "Expression: %a\n" PP.expression entry.result ;
+  let%bind ex_ty_value = Of_michelson.evaluate ?options code in
-    Format.printf "Input: %a\n" PP.value input ;
+  Compile.Of_mini_c.uncompile_value ex_ty_value
-    Format.printf "Input Type: %a\n" PP.type_ (fst ty) ;
+
-    Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ;
+let run_function ?options expression input ty =
-  ) ;
+  let%bind code = Compile.Of_mini_c.compile_function expression in
-  let%bind ex_ty_value = Of_michelson.run ?options compiled input_michelson in
+  let%bind input = Compile.Of_mini_c.compile_value input ty in
-  if debug_michelson then (
+  let%bind ex_ty_value = Of_michelson.run ?options code input in
-    let (Ex_typed_value (ty , v)) = ex_ty_value in
+  Compile.Of_mini_c.uncompile_value ex_ty_value
-    ignore @@
+
-    let%bind michelson_value =
+let run_function_entry ?options program entry input =
-      trace_tzresult_lwt (simple_error "debugging run_mini_c") @@
+  let%bind code = Compile.Of_mini_c.compile_function_entry program entry in
-      Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_data ty v in
+  let%bind input_michelson =
-    Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ;
+    let%bind code = Compile.Of_mini_c.compile_expression_as_function input in
-    ok ()
+    let%bind (Ex_typed_value (ty , value)) = Of_michelson.evaluate ?options code in
-  ) ;
+    Trace.trace_tzresult_lwt (simple_error "error unparsing input") @@
-  let%bind (result : value) = Compile.Of_mini_c.uncompile_value ex_ty_value in
+    Memory_proto_alpha.unparse_michelson_data ty value
-  ok result
+  in
+  let%bind ex_ty_value = Of_michelson.run ?options code input_michelson in
+  Compile.Of_mini_c.uncompile_value ex_ty_value

src/main/run/of_simplified.ml

@@ -18,15 +18,10 @@ let run_typed_program
   let%bind ex_ty_value = Of_michelson.run ?options code input in
   Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value
 
-
 let evaluate_typed_program_entry
     ?options
     (program : Ast_typed.program) (entry : string)
   : Ast_simplified.expression result =
-  let%bind code = Compile.Of_typed.compile_expression_entry program entry in
+  let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in
-  let%bind input =
+  let%bind ex_ty_value = Of_michelson.evaluate ?options code in
-    let fake_input = Ast_typed.(e_a_unit Environment.full_empty) in
-
-  in
-  let%bind ex_ty_value = Of_michelson.run ?options code input in
   Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry ex_ty_value

src/main/run/of_source.ml

@@ -76,7 +76,7 @@ let run_function ?amount source_filename entry_point input syntax =
 
 let evaluate ?amount source_filename entry_point syntax =
   let%bind program = Compile.Of_source.type_file syntax source_filename in
-  let%bind code = Compile.Of_typed.compile_expression_entry program entry_point in
+  let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry_point in
   let%bind input =
     let fake_input = Ast_simplified.e_unit () in
     Compile.Of_simplified.compile_expression fake_input

src/main/run/of_typed.ml

@@ -21,14 +21,10 @@ let run_entry
 
 let evaluate ?options (e : annotated_expression) : annotated_expression result =
   let%bind code = Compile.Of_typed.compile_expression_as_function e in
-  let fake_input = e_a_unit Environment.full_empty in
+  let%bind ex_ty_value = Of_michelson.evaluate ?options code in
-  let%bind input = Compile.Of_typed.compile_expression fake_input in
-  let%bind ex_ty_value = Of_michelson.run ?options code input in
   Compile.Of_typed.uncompile_value ex_ty_value e.type_annotation
 
 let evaluate_entry ?options program entry =
-  let%bind code = Compile.Of_typed.compile_expression_entry program entry in
+  let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in
-  let fake_input = e_a_unit Environment.full_empty in
+  let%bind ex_ty_value = Of_michelson.evaluate ?options code in
-  let%bind input = Compile.Of_typed.compile_expression fake_input in
-  let%bind ex_ty_value = Of_michelson.run ?options code input in
   Compile.Of_typed.uncompile_entry_expression_result program entry ex_ty_value

src/passes/6-transpiler/transpiler.ml

@@ -313,7 +313,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
               let%bind f' = match f.expression with
                 | E_lambda l -> (
                     let%bind body' = transpile_annotated_expression l.body in
-                    let%bind (input , _) = get_t_function f.type_annotation in
+                    let%bind (input , _) = AST.get_t_function f.type_annotation in
                     let%bind input' = transpile_type input in
                     ok ((l.binder , input') , body')
                   )
@@ -326,7 +326,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
                         match f.expression with
                         | E_lambda l -> (
                             let%bind body' = transpile_annotated_expression l.body in
-                            let%bind (input , _) = get_t_function f.type_annotation in
+                            let%bind (input , _) = AST.get_t_function f.type_annotation in
                             let%bind input' = transpile_type input in
                             ok ((l.binder , input') , body')
                           )
@@ -357,7 +357,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
     let%bind env =
       trace_strong (corner_case ~loc:__LOC__ "environment") @@
       transpile_environment ae.environment in
-    let%bind io = get_t_function ae.type_annotation in
+    let%bind io = AST.get_t_function ae.type_annotation in
     transpile_lambda env l io
   | E_list lst -> (
       let%bind t =
@@ -513,8 +513,8 @@ and transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> _ -> Mini_c.ex
   let%bind (f_expr' , input_tv , output_tv) =
     let%bind raw_input = transpile_type input_type in
     let%bind output = transpile_type output_type in
-    let%bind result = transpile_annotated_expression body in
+    let%bind body = transpile_annotated_expression body in
-    let expr' = E_closure { binder ; result } in
+    let expr' = E_closure { binder ; body } in
     ok (expr' , raw_input , output) in
   let tv = Mini_c.t_deep_closure c_env input_tv output_tv in
   ok @@ Expression.make_tpl (f_expr' , tv)
@@ -529,7 +529,7 @@ and transpile_lambda env l (input_type , output_type) =
         let%bind input = transpile_type input_type in
         let%bind output = transpile_type output_type in
         let tv = Combinators.t_function input output in
-        let content = D_function { binder ; result = result'} in
+        let content = D_function { binder ; body = result'} in
         ok @@ Combinators.Expression.make_tpl (E_literal content , tv)
       )
     | _ -> (
@@ -545,7 +545,7 @@ let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
       let env' = Environment.add (name, tv) env in
       ok @@ ((name, expression), environment_wrap env env')
 
-let transpile_program (lst:AST.program) : program result =
+let transpile_program (lst : AST.program) : program result =
   let aux (prev:(toplevel_statement list * Environment.t) result) cur =
     let%bind (tl, env) = prev in
     let%bind ((_, env') as cur') = transpile_declaration env cur in

src/passes/8-compiler/compiler_program.ml

@@ -361,10 +361,10 @@ and translate_expression (expr:expression) (env:environment) : michelson result
       ]
     )
 
-and translate_function_body ({result ; binder} : anon_function) lst input : michelson result =
+and translate_function_body ({body ; binder} : anon_function) lst input : michelson result =
   let pre_env = Environment.of_list lst in
   let env = Environment.(add (binder , input) pre_env) in
-  let%bind expr_code = translate_expression result env in
+  let%bind expr_code = translate_expression body env in
   let%bind unpack_closure_code = Compiler_environment.unpack_closure pre_env in
   let code = seq [
       i_comment "unpack closure env" ;

src/stages/ast_typed/combinators.ml

@@ -60,6 +60,11 @@ let get_lambda e : _ result = match e with
   | E_lambda l -> ok l
   | _ -> simple_fail "not a lambda"
 
+let get_lambda_with_type e =
+  match (e.expression , e.type_annotation.type_value') with
+  | E_lambda l , T_function io -> ok (l , io)
+  | _ -> simple_fail "not a lambda with functional type"
+
 let get_t_bool (t:type_value) : unit result = match t.type_value' with
   | T_constant ("bool", []) -> ok ()
   | _ -> simple_fail "not a bool"

src/stages/ast_typed/misc.ml

@@ -125,6 +125,23 @@ module Errors = struct
       ("missing_key" , fun () -> Format.asprintf "%s" k)
     ] in
     error ~data title message ()
+
+  let missing_entry_point name =
+    let title () = "missing entry point" in
+    let content () = "no entry point with the given name" in
+    let data = [
+      ("name" , fun () -> name) ;
+    ] in
+    error ~data title content
+
+  let not_functional_main location =
+    let title () = "not functional main" in
+    let content () = "main should be a function" in
+    let data = [
+      ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
+    ] in
+    error ~data title content
+
 end
 
 module Free_variables = struct
@@ -473,3 +490,13 @@ let merge_annotation (a:type_value option) (b:type_value option) err : type_valu
       match a.simplified, b.simplified with
       | _, None -> ok a
       | _, Some _ -> ok b
+
+let get_entry (lst : program) (name : string) : annotated_expression result =
+  trace_option (Errors.missing_entry_point name) @@
+  let aux x =
+    let (Declaration_constant (an , _)) = Location.unwrap x in
+    if (an.name = name)
+    then Some an.annotated_expression
+    else None
+  in
+  List.find_map aux lst

src/stages/ast_typed/types.ml

@@ -148,23 +148,3 @@ and 'a matching =
   | Match_variant of (((constructor_name * name) * 'a) list * type_value)
 
 and matching_expr = ae matching
-
-open Trace
-
-let get_entry (p:program) (entry : string) : annotated_expression result =
-  let aux (d:declaration) =
-    match d with
-    | Declaration_constant ({name ; annotated_expression} , _) when entry = name -> Some annotated_expression
-    | Declaration_constant _ -> None
-  in
-  let%bind result =
-    trace_option (simple_error "no entry point with given name") @@
-    List.find_map aux (List.map Location.unwrap p) in
-  ok result
-
-let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result =
-  let%bind entry = get_entry p entry in
-  match entry.expression with
-  | E_lambda l -> ok (l , entry.type_annotation)
-  | _ -> simple_fail "given entry point is not functional"
-

src/stages/mini_c/PP.ml

@@ -100,10 +100,10 @@ and expression_with_type : _ -> expression -> _  = fun ppf e ->
     expression' e.content
     type_ e.type_value
 
-and function_ ppf ({binder ; result}:anon_function) =
+and function_ ppf ({binder ; body}:anon_function) =
   fprintf ppf "fun %s -> (%a)"
     binder
-    expression result
+    expression body
 
 and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e
 

src/stages/mini_c/combinators.ml

@@ -7,18 +7,15 @@ module Expression = struct
 
   let get_content : t -> t' = fun e -> e.content
   let get_type : t -> type_value = fun e -> e.type_value
-  let is_toplevel : t -> bool = fun e -> e.is_toplevel
 
-  let make = fun ?(itl = false) e' t -> {
+  let make = fun e' t -> {
     content = e' ;
     type_value = t ;
-    is_toplevel = itl ;
   }
 
-  let make_tpl = fun ?(itl = false) (e' , t) -> {
+  let make_tpl = fun (e' , t) -> {
     content = e' ;
     type_value = t ;
-    is_toplevel = itl ;
   }
 
   let pair : t -> t -> t' = fun a b -> E_constant ("PAIR" , [ a ; b ])
@@ -70,6 +67,20 @@ let get_set (v:value) = match v with
   | D_set lst -> ok lst
   | _ -> simple_fail "not a set"
 
+let get_function_with_ty (e : expression) =
+  match (e.content , e.type_value) with
+  | E_literal (D_function f) , T_function ty -> ok (f , ty)
+  | _ -> simple_fail "not a function with functional type"
+
+let get_function (e : expression) =
+  match (e.content) with
+  | E_literal (D_function f) -> ok (D_function f)
+  | _ -> simple_fail "not a function"
+
+let get_t_function tv = match tv with
+  | T_function ty -> ok ty
+  | _ -> simple_fail "not a function"
+
 let get_t_option (v:type_value) = match v with
   | T_option t -> ok t
   | _ -> simple_fail "not an option"
@@ -146,10 +157,10 @@ let t_deep_closure x y z : type_value = T_deep_closure ( x , y , z )
 let t_pair x y : type_value = T_pair ( x , y )
 let t_union x y : type_value = T_or ( x , y )
 
-let quote binder result : anon_function =
+let quote binder body : anon_function =
   {
     binder ;
-    result ;
+    body ;
   }
 
 
@@ -157,7 +168,7 @@ let e_int expr : expression = Expression.make_tpl (expr, t_int)
 let e_unit : expression = Expression.make_tpl (E_literal D_unit, t_unit)
 let e_skip : expression = Expression.make_tpl (E_skip, t_unit)
 let e_var_int name : expression = e_int (E_variable name)
-let e_let_int v tv expr body : expression = Expression.(make_tpl (
+let e_let_in v tv expr body : expression = Expression.(make_tpl (
     E_let_in ((v , tv) , expr , body) ,
     get_type body
   ))
@@ -166,11 +177,12 @@ let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl
 
 let d_unit : value = D_unit
 
-let basic_quote expr : anon_function result =
+let basic_quote expr in_ty out_ty : expression result =
-  ok @@ quote "input" expr
+  let expr' = E_literal (D_function (quote "input" expr)) in
+  ok @@ Expression.make_tpl (expr' , t_function in_ty out_ty)
 
-let basic_int_quote expr : anon_function result =
+let basic_int_quote expr : expression result =
-  basic_quote expr
+  basic_quote expr t_int t_int
 
 
 let environment_wrap pre_environment post_environment = { pre_environment ; post_environment }

src/stages/mini_c/mini_c.ml

@@ -8,3 +8,4 @@ module Combinators = struct
 end
 include Combinators
 module Environment = Environment
+include Misc

src/stages/mini_c/misc.ml

@@ -0,0 +1,93 @@
+open Types
+open Combinators
+open Trace
+
+module Errors = struct
+
+  let missing_entry_point name =
+    let title () = "missing entry point" in
+    let content () = "no entry point with the given name" in
+    let data = [
+      ("name" , fun () -> name) ;
+    ] in
+    error ~data title content
+
+  let not_functional_main name =
+    let title () = "not functional main" in
+    let content () = "main should be a function" in
+    let data = [
+      ("name" , fun () -> Format.asprintf "%s" name) ;
+    ] in
+    error ~data title content
+
+end
+
+(*
+   Converts `expr` in `fun () -> expr`.
+*)
+let functionalize (body : expression) : expression =
+  let content = E_literal (D_function { binder = "_" ; body }) in
+  let type_value = t_function t_unit body.type_value in
+  { content ; type_value }
+
+let get_entry (lst : program) (name : string) : (expression * int) result =
+  let%bind entry_expression =
+    trace_option (Errors.missing_entry_point name) @@
+    let aux x =
+      let (((decl_name , decl_expr) , _)) = x in
+      if (decl_name = name)
+      then Some decl_expr
+      else None
+    in
+    List.find_map aux lst
+  in
+  let entry_index =
+    let aux x =
+      let (((decl_name , _) , _)) = x in
+      decl_name = name
+    in
+    List.find_index aux lst
+  in
+  ok (entry_expression , entry_index)
+
+
+(*
+   Assume the following code:
+   ```
+     const x = 42
+     const y = 120
+     const z = 423
+     const f = () -> x + y
+   ```
+   It is transformed in:
+   ```
+     const f = () ->
+       let x = 42 in
+       let y = 120 in
+       let z = 423 in
+       x + y
+   ```
+
+   The entry-point can be an expression, which is then functionalized if
+   `to_functionalize` is set to true.
+*)
+let aggregate_entry (lst : program) (name : string) (to_functionalize : bool) : expression result =
+  let%bind (entry_expression , entry_index) = get_entry lst name in
+  let pre_declarations = List.until entry_index lst in
+  let wrapper =
+    let aux prec cur =
+      let (((name , expr) , _)) = cur in
+      e_let_in name expr.type_value expr prec
+    in
+    fun expr -> List.fold_right' aux expr pre_declarations
+  in
+  match (entry_expression.content , to_functionalize) with
+  | (E_literal (D_function l) , false) -> (
+      let l' = { l with body = wrapper l.body } in
+      let e' = { entry_expression with content = E_literal (D_function l') } in
+      ok e'
+    )
+  | (_ , true) -> (
+      ok @@ functionalize @@ wrapper entry_expression
+    )
+  | _ -> fail @@ Errors.not_functional_main name

src/stages/mini_c/types.ml

@@ -78,7 +78,6 @@ and expression' =
 and expression = {
   content : expression' ;
   type_value : type_value ;
-  is_toplevel : bool ;
 }
 
 and assignment = var_name * expression
@@ -87,7 +86,7 @@ and toplevel_statement = assignment * environment_wrap
 
 and anon_function = {
   binder : string ;
-  result : expression ;
+  body : expression ;
 }
 
 and program = toplevel_statement list

src/test/compiler_tests.ml

@@ -3,9 +3,9 @@ open Mini_c
 open Combinators
 open Test_helpers
 
-let run_entry_int (e:anon_function) (n:int) : int result =
+let run_entry_int e (n:int) : int result =
   let param : value = D_int n in
-  let%bind result = Run.Of_mini_c.run_entry e (t_int , t_int) param in
+  let%bind result = Run.Of_mini_c.run_function e param t_int in
   match result with
   | D_int n -> ok n
   | _ -> simple_fail "result is not an int"
@@ -18,10 +18,10 @@ let identity () : unit result =
 
 let multiple_vars () : unit result =
   let expr =
-    e_let_int "a" t_int (e_var_int "input") @@
+    e_let_in "a" t_int (e_var_int "input") @@
-    e_let_int "b" t_int (e_var_int "input") @@
+    e_let_in "b" t_int (e_var_int "input") @@
-    e_let_int "c" t_int (e_var_int "a") @@
+    e_let_in "c" t_int (e_var_int "a") @@
-    e_let_int "output" t_int (e_var_int "c") @@
+    e_let_in "output" t_int (e_var_int "c") @@
     e_var_int "output" in
   let%bind f = basic_int_quote expr in
   let%bind result = run_entry_int f 42 in

vendors/ligo-utils/tezos-utils/x_michelson.ml

@@ -15,7 +15,6 @@ let annotate annot = function
 
 let seq s : michelson = Seq (0, s)
 
-let i_comment s : michelson = seq [ prim ~annot:["\"" ^ s ^ "\""] I_UNIT ; prim I_DROP ]
 
 let contract parameter storage code =
   seq [
@@ -45,6 +44,9 @@ let i_piar = seq [ i_swap ; i_pair ]
 let i_push ty code = prim ~children:[ty;code] I_PUSH
 let i_push_unit = i_push t_unit d_unit
 let i_push_string str = i_push t_string (string str)
+
+let i_comment s : michelson = seq [ i_push_string s ; prim I_DROP ]
+
 let i_none ty = prim ~children:[ty] I_NONE
 let i_nil ty = prim ~children:[ty] I_NIL
 let i_empty_set ty = prim ~children:[ty] I_EMPTY_SET