review 3

src/bin/expect_tests/contract_tests.ml

@@ -1174,7 +1174,7 @@ let%expect_test _ =
 let%expect_test _ =
   run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
   [%expect {|
-ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#808 = #P in let p = rhs#808.0 in let s = rhs#808.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
+ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#811 = #P in let p = rhs#811.0 in let s = rhs#811.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
 
 
  If you're not sure how to fix this error, you can
@@ -1187,7 +1187,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8,
 
   run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
   [%expect {|
-ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#811 = #P in let p = rhs#811.0 in let s = rhs#811.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
+ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#814 = #P in let p = rhs#814.0 in let s = rhs#814.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
 
 
  If you're not sure how to fix this error, you can

src/bin/expect_tests/ligo_interpreter_tests.ml

@@ -53,4 +53,5 @@ let%expect_test _ =
     val s = { ; 1 : int ; 2 : int ; 3 : int}
     val set_add = {  ; 0 = ({ ; 1 : int ; 2 : int ; 3 : int}) ; 1 = ({ ; 1 : int ; 2 : int ; 3 : int ; 4 : int}) ; 2 = ({ ; 1 : int}) }
     val set_iter_fail = "set_iter_fail" : failure
-    val set_mem = {  ; 0 = (true) ; 1 = (false) ; 2 = (false) } |}] ;
+    val set_mem = {  ; 0 = (true) ; 1 = (false) ; 2 = (false) }
+    val recursion = 55 : int |}] ;

src/bin/expect_tests/typer_error_tests.ml

@@ -42,7 +42,7 @@ let%expect_test _ =
 
   run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_no_tail_recursive_function.mligo"; "f"];
   [%expect {|
-    ligo: in file "error_no_tail_recursive_function.mligo", line 2, characters 14-21. Recursive call is only allowed as the last operation:  {"function":"unvalid","location":"in file \"error_no_tail_recursive_function.mligo\", line 2, characters 14-21"}
+    ligo: in file "error_no_tail_recursive_function.mligo", line 2, characters 14-21. Recursion must be achieved through tail-calls only:  {"function":"unvalid","location":"in file \"error_no_tail_recursive_function.mligo\", line 2, characters 14-21"}
 
 
      If you're not sure how to fix this error, you can

src/passes/6-interpreter/interpreter.ml

@@ -277,10 +277,17 @@ and eval : Ast_typed.expression -> env -> value result
         let%bind args' = eval args env in
         let f_env' = Env.extend f_env (arg_names, args') in
         eval body f_env'
+      | V_Func_rec (_fun_name,_fun_type,lambda, _env) ->
+        let%bind args' = eval args env in
+        let f_env' = Env.extend env (lambda.binder,args') in
+        eval lambda.result f_env'
       | _ -> simple_fail "trying to apply on something that is not a function"
     )
-    | E_lambda { binder; result;} ->
+    | E_lambda {binder; result;} ->
       ok @@ V_Func_val (binder,result,env)
+    | E_recursive {fun_name; fun_type;lambda} ->
+      let env' = Env.extend env (fun_name, V_Func_rec(fun_name,fun_type,lambda,env)) in
+      ok @@ V_Func_rec (fun_name,fun_type,lambda,env')
     | E_let_in { let_binder; rhs; let_result; _} ->
       let%bind rhs' = eval rhs env in
       eval let_result (Env.extend env (let_binder,rhs'))
@@ -371,7 +378,7 @@ and eval : Ast_typed.expression -> env -> value result
       | _ -> simple_fail "not yet supported case"
         (* ((ctor,name),body) *)
     )
-    | E_look_up _ | E_recursive _ ->
+    | E_look_up _ ->
       let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in
       simple_fail serr
 

src/passes/6-transpiler/transpiler.ml

@@ -536,22 +536,23 @@ and transpile_recursive {fun_name; fun_type; lambda} =
         let%bind (body,l) = map_lambda fun_name loop_type result in
         ok @@ (Expression.make (E_closure {binder;body}) loop_type, binder::l)
       | _  -> 
-        let%bind res = replace_callback fun_name loop_type e in
+        let%bind res = replace_callback fun_name loop_type false e in
         ok @@ (res, [])
 
-  and replace_callback : AST.expression_variable -> type_value -> AST.expression -> expression result = fun fun_name loop_type e ->
+  and replace_callback : AST.expression_variable -> type_value -> bool -> AST.expression -> expression result = fun fun_name loop_type shadowed e ->
     match e.expression_content with
-      E_let_in li ->
+      E_let_in li -> 
-        let%bind let_result = replace_callback fun_name loop_type li.let_result in
+        let shadowed = shadowed || Var.equal li.let_binder fun_name in 
+        let%bind let_result = replace_callback fun_name loop_type shadowed li.let_result in
         let%bind rhs = transpile_annotated_expression li.rhs in
         let%bind ty  = transpile_type e.type_expression in
         ok @@ e_let_in li.let_binder ty li.inline rhs let_result |
       E_matching m -> 
         let%bind ty = transpile_type e.type_expression in
-        matching fun_name loop_type m ty |
+        matching fun_name loop_type shadowed m ty |
       E_application {expr1;expr2} -> (
-        match expr1.expression_content with
+        match expr1.expression_content,shadowed with
-        E_variable name when Var.equal fun_name name -> 
+        E_variable name, false when Var.equal fun_name name -> 
           let%bind expr = transpile_annotated_expression expr2 in
           ok @@ Expression.make (E_constant {cons_name=C_LOOP_CONTINUE;arguments=[expr]}) loop_type |
         _ -> 
@@ -561,18 +562,18 @@ and transpile_recursive {fun_name; fun_type; lambda} =
       _ -> 
         let%bind expr = transpile_annotated_expression e in
         ok @@ Expression.make (E_constant {cons_name=C_LOOP_STOP;arguments=[expr]}) loop_type
-  and matching : AST.expression_variable -> type_value -> AST.matching -> type_value -> expression result = fun fun_name loop_type m ty ->
+  and matching : AST.expression_variable -> type_value -> bool -> AST.matching -> type_value -> expression result = fun fun_name loop_type shadowed m ty ->
     let return ret = ok @@ Expression.make ret @@ ty in
     let%bind expr = transpile_annotated_expression m.matchee in
     match m.cases with
       Match_bool {match_true; match_false} -> 
-          let%bind (t , f) = bind_map_pair (replace_callback fun_name loop_type) (match_true, match_false) in
+          let%bind (t , f) = bind_map_pair (replace_callback fun_name loop_type shadowed) (match_true, match_false) in
           return @@ E_if_bool (expr, t, f)
       | Match_option { match_none; match_some = (name, s, tv) } ->
-          let%bind n = replace_callback fun_name loop_type match_none in
+          let%bind n = replace_callback fun_name loop_type shadowed match_none in
           let%bind (tv' , s') =
             let%bind tv' = transpile_type tv in
-            let%bind s' = replace_callback fun_name loop_type s in
+            let%bind s' = replace_callback fun_name loop_type shadowed s in
             ok (tv' , s')
           in
           return @@ E_if_none (expr , n , ((name , tv') , s'))
@@ -580,10 +581,10 @@ and transpile_recursive {fun_name; fun_type; lambda} =
           match_nil ;
           match_cons = ((hd_name) , (tl_name), match_cons, ty) ;
         } -> (
-          let%bind nil = replace_callback fun_name loop_type match_nil in
+          let%bind nil = replace_callback fun_name loop_type shadowed match_nil in
           let%bind cons =
             let%bind ty' = transpile_type ty in
-            let%bind match_cons' = replace_callback fun_name loop_type match_cons in
+            let%bind match_cons' = replace_callback fun_name loop_type shadowed match_cons in
             ok (((hd_name , ty') , (tl_name , ty')) , match_cons')
           in
           return @@ E_if_cons (expr , nil , cons)
@@ -614,7 +615,7 @@ and transpile_recursive {fun_name; fun_type; lambda} =
                 let%bind ((_ , name) , body) =
                   trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
                   List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
-                let%bind body' = replace_callback fun_name loop_type body in
+                let%bind body' = replace_callback fun_name loop_type shadowed body in
                 return @@ E_let_in ((name , tv) , false , top , body')
               )
             | ((`Node (a , b)) , tv) ->

src/passes/8-compiler/compiler_program.ml

@@ -59,13 +59,12 @@ let rec get_operator : constant' -> type_value -> expression list -> predicate r
       | C_LOOP_CONTINUE -> (
           let%bind (_,ty) = get_t_or ty in
           let%bind m_ty = Compiler_type.type_ ty in
-          let m_ty' = t_pair t_unit m_ty in
+          ok @@ simple_unary @@ prim ~children:[m_ty] I_LEFT
-          ok @@ simple_unary @@ prim ~children:[m_ty'] I_LEFT
       )
       | C_LOOP_STOP -> (
           let%bind (ty, _) = get_t_or ty in
           let%bind m_ty = Compiler_type.type_ ty in
-          ok @@ simple_unary @@ seq [ i_push_unit; i_pair; prim ~children:[m_ty] I_RIGHT]
+          ok @@ simple_unary @@ prim ~children:[m_ty] I_RIGHT
       )
       | C_SET_EMPTY -> (
           let%bind ty' = Mini_c.get_t_set ty in
@@ -410,12 +409,10 @@ and translate_expression (expr:expression) (env:environment) : michelson result
       | C_LOOP_LEFT -> (
           let%bind (_, ty) = get_t_or (snd v) in
           let%bind m_ty = Compiler_type.type_ ty in
-          let m_ty' = t_pair t_unit m_ty in
           let%bind code = ok (seq [
               expr' ;
-              prim ~children:[m_ty'] I_LEFT;
+              prim ~children:[m_ty] I_LEFT;
               i_loop_left body';
-              prim I_CDR
             ]) in
           return code
         )

src/stages/ligo_interpreter/PP.ml

@@ -19,6 +19,7 @@ let rec pp_value : value -> string = function
       recmap "" in
     Format.asprintf "{ %s }" content
   | V_Func_val _ -> Format.asprintf "<fun>"
+  | V_Func_rec _ -> Format.asprintf "<rec fun>"
   | V_Construct (name,v) -> Format.asprintf "%s(%s)" name (pp_value v)
   | V_List vl ->
     Format.asprintf "[%s]" @@
@@ -36,4 +37,4 @@ let pp_env : env -> unit = fun env ->
     Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v))
   env in
   let () = Format.printf "\n}\n" in
-  ()
+  ()

src/stages/ligo_interpreter/types.ml

@@ -31,6 +31,7 @@ and constant_val =
 
 and value =
   | V_Func_val of (expression_variable * Ast_typed.expression * env)
+  | V_Func_rec of (expression_variable * Ast_typed.type_expression * Ast_typed.lambda * env)
   | V_Ct of constant_val
   | V_List of value list
   | V_Record of value label_map

src/test/contracts/interpret_test.mligo

@@ -232,3 +232,10 @@ let set_mem =
   Set.mem 1 s,
   Set.mem 4 s,
   Set.mem 1 (Set.empty : int set)
+
+let recursion =
+  let rec sum : int*int -> int = fun ((n,res):int*int) ->
+    let i = 1 in
+    if (n<1) then res else sum (n-i,res+n)
+  in
+  sum (10,0)

test.mligo

@@ -0,0 +1,8 @@
+let rec fibo2 ((n,n_1,n_0):int*int*int) : int =
+  let fibo2 : int -> int = fun (k : int) -> k in
+  if (n < 2) then n_1 else fibo2 3
+
+let main (p,s : unit * int) : operation list * int =
+  let x : int = fibo2 (5, 1, 1) in
+  (([] : operation list), x)
+