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

Merge branch 'ast/tail_recursion' into 'dev'

Browse Source 
Adding tail recursion in Ligo

See merge request ligolang/ligo!491
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-03-12 18:47:46 +00:00
commit eecdbcddf7
68 changed files with 3976 additions and 2646 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gitlab-pages/docs/language-basics/functions.md
View File

@ -299,3 +299,43 @@ gitlab-pages/docs/language-basics/src/functions/incr_map.religo incr_map
</Syntax>
## Recursive function
LIGO functions are not recursive by default, the user need to indicate that the function is recursive.
At the moment, recursive function are limited to one (possibly tupled) parameter and recursion is
limited to tail recursion (i.e the recursive call should be the last expression of the function)
<Syntax syntax="pascaligo">
In PascaLigo recursive functions are defined using the `recursive` keyword
```pascaligo group=d
recursive function sum (const n : int; const acc: int) : int is
if n<1 then acc else sum(n-1,acc+n)
recursive function fibo (const n: int; const n_1: int; const n_0 :int) : int is
if n<2 then n_1 else fibo(n-1,n_1+n_0,n_1)
```
</Syntax>
<Syntax syntax="cameligo">
In CameLigo recursive functions are defined using the `rec` keyword
```cameligo group=d
let rec sum ((n,acc):int * int) : int =
if (n < 1) then acc else sum (n-1, acc+n)
let rec fibo ((n,n_1,n_0):int*int*int) : int =
if (n < 2) then n_1 else fibo (n-1, n_1 + n_0, n_1)
```
</Syntax>
<Syntax syntax="reasonligo">
In ReasonLigo recursive functions are defined using the `rec` keyword
```reasonligo group=d
let rec sum = ((n, acc) : (int,int)): int =>
if (n < 1) {acc;} else {sum ((n-1,acc+n));};
let rec fibo = ((n, n_1, n_0) : (int,int,int)): int =>
if (n < 2) {n_1;} else {fibo ((n-1,n_1+n_0,n_1));};
```
</Syntax>

69
gitlab-pages/docs/language-basics/loops.md
View File

@ -57,45 +57,21 @@ constant, therefore it makes no sense in CameLIGO to feature loops,
which we understand as syntactic constructs where the state of a
stopping condition is mutated, as with "while" loops in PascaLIGO.
Instead, CameLIGO implements a *folded operation* by means of a
predefined function named `Loop.fold_while`. It takes an initial value
of a certain type, called an *accumulator*, and repeatedly calls a
given function, called *folded function*, that takes that
accumulator and returns the next value of the accumulator, until a
condition is met and the fold stops with the final value of the
accumulator. The iterated function needs to have a special type: if
the type of the accumulator is `t`, then it must have the type `bool *
t` (not simply `t`). It is the boolean value that denotes whether the
stopping condition has been reached.
Instead, CameLIGO loops are written by means of a tail recursive function
Here is how to compute the greatest common divisors of two natural
numbers by means of Euclid's algorithm:
```cameligo group=a
let iter (x,y : nat * nat) : bool * (nat * nat) =
if y = 0n then false, (x,y) else true, (y, x mod y)
let rec iter (x,y : nat * nat) : nat =
if y = 0n then x else iter (y, x mod y)
let gcd (x,y : nat * nat) : nat =
let x,y = if x < y then y,x else x,y in
let x,y = Loop.fold_while iter (x,y)
in x
iter (x,y)
```
To ease the writing and reading of the iterated functions (here,
`iter`), two predefined functions are provided: `Loop.resume` and
`Loop.stop`:
```cameligo group=a
let iter (x,y : nat * nat) : bool * (nat * nat) =
if y = 0n then Loop.stop (x,y) else Loop.resume (y, x mod y)
let gcd (x,y : nat * nat) : nat =
let x,y = if x < y then y,x else x,y in
let x,y = Loop.fold_while iter (x,y)
in x
```
> Note that `stop` and `continue` (now `Loop.resume`) are
> Note that `fold_while`, `stop` and `continue` (now `Loop.resume`) are
> *deprecated*.
You can call the function `gcd` defined above using the LIGO compiler
@ -114,47 +90,22 @@ constant, therefore it makes no sense in ReasonLIGO to feature loops,
which we understand as syntactic constructs where the state of a
stopping condition is mutated, as with "while" loops in PascaLIGO.
Instead, ReasonLIGO features a *fold operation* as a predefined
function named `Loop.fold_while`. It takes an initial value of a
certain type, called an *accumulator*, and repeatedly calls a given
function, called *iterated function*, that takes that accumulator and
returns the next value of the accumulator, until a condition is met
and the fold stops with the final value of the accumulator. The
iterated function needs to have a special type: if the type of the
accumulator is `t`, then it must have the type `bool * t` (not simply
`t`). It is the boolean value that denotes whether the stopping
condition has been reached.
Instead, ReasonLIGO loops are written by means of tail recursive functions
Here is how to compute the greatest common divisors of two natural
numbers by means of Euclid's algorithm:
```reasonligo group=a
let iter = ((x,y) : (nat, nat)) : (bool, (nat, nat)) =>
if (y == 0n) { (false, (x,y)); } else { (true, (y, x mod y)); };
let rec iter = ((x,y) : (nat, nat)) : nat =>
if (y == 0n) { x; } else { iter ((y, x mod y)); };
let gcd = ((x,y) : (nat, nat)) : nat => {
let (x,y) = if (x < y) { (y,x); } else { (x,y); };
let (x,y) = Loop.fold_while (iter, (x,y));
x
iter ((x,y))
};
```
To ease the writing and reading of the iterated functions (here,
`iter`), two predefined functions are provided: `Loop.resume` and
`Loop.stop`:
```reasonligo group=b
let iter = ((x,y) : (nat, nat)) : (bool, (nat, nat)) =>
if (y == 0n) { Loop.stop ((x,y)); } else { Loop.resume ((y, x mod y)); };
let gcd = ((x,y) : (nat, nat)) : nat => {
let (x,y) = if (x < y) { (y,x); } else { (x,y); };
let (x,y) = Loop.fold_while (iter, (x,y));
x
};
```
> Note that `stop` and `continue` (now `Loop.resume`) are
> Note that `fold_while`, `stop` and `continue` (now `Loop.resume`) are
> *deprecated*.
</Syntax>

4
src/bin/expect_tests/contract_tests.ml
View File

@ -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 : ( nat * string ):Some(( nat * string ))) : None return let rhs#809 = #P in let p = rhs#809.0 in let s = rhs#809.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#812 = #P in let p = rhs#812.0 in let s = rhs#812.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 : ( nat * int ):Some(( nat * int ))) : None return let rhs#812 = #P in let p = rhs#812.0 in let s = rhs#812.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#815 = #P in let p = rhs#815.0 in let s = rhs#815.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

5
src/bin/expect_tests/ligo_interpreter_tests.ml
View File

@ -53,4 +53,7 @@ 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_let_rec_in = 55 : int
val sum_rec = <rec fun>
val top_level_recursion = 55 : int |}] ;

13
src/bin/expect_tests/typer_error_tests.ml
View File

@ -32,6 +32,19 @@ let%expect_test _ =
ligo: in file "", line 0, characters 0-0. different kinds: {"a":"( (TO_list(operation)) * sum[Add -> int , Sub -> int] )","b":"sum[Add -> int , Sub -> int]"}
If you're not sure how to fix this error, you can
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
* Ask a question on our Discord: https://discord.gg/9rhYaEt
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
* Check the changelog by running 'ligo changelog' |}];
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. 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
do one of the following:

2
src/main/compile/dune
View File

@ -9,10 +9,10 @@
interpreter
ast_simplified
self_ast_simplified
self_ast_typed
typer_new
typer
ast_typed
self_ast_typed
transpiler
mini_c
self_mini_c

9
src/main/compile/of_simplified.ml
View File

@ -7,10 +7,11 @@ type form =
let compile (cform: form) (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solver.state) result =
let%bind (prog_typed , state) = Typer.type_program program in
let () = Typer.Solver.discard_state state in
let%bind prog_typed' = match cform with
| Contract entrypoint -> Self_ast_typed.all_contract entrypoint prog_typed
| Env -> ok prog_typed in
ok @@ (prog_typed', state)
let%bind applied = Self_ast_typed.all_program prog_typed in
let%bind applied' = match cform with
| Contract entrypoint -> Self_ast_typed.all_contract entrypoint applied
| Env -> ok applied in
ok @@ (applied', state)
let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression)
: (Ast_typed.expression * Typer.Solver.state) result =

4
src/passes/1-parser/cameligo/AST.ml
View File

@ -30,6 +30,7 @@ type kwd_else = Region.t
type kwd_end = Region.t
type kwd_false = Region.t
type kwd_fun = Region.t
type kwd_rec = Region.t
type kwd_if = Region.t
type kwd_in = Region.t
type kwd_let = Region.t
@ -134,7 +135,7 @@ and ast = t
and attributes = attribute list
and declaration =
Let of (kwd_let * let_binding * attributes) reg
Let of (kwd_let * kwd_rec option * let_binding * attributes) reg
| TypeDecl of type_decl reg
(* Non-recursive values *)
@ -362,6 +363,7 @@ and 'a case_clause = {
and let_in = {
kwd_let : kwd_let;
kwd_rec : kwd_rec option;
binding : let_binding;
kwd_in : kwd_in;
body : expr;

1
src/passes/1-parser/cameligo/LexToken.mli
View File

@ -95,6 +95,7 @@ type t =
| End of Region.t
| False of Region.t
| Fun of Region.t
| Rec of Region.t
| If of Region.t
| In of Region.t
| Let of Region.t

6
src/passes/1-parser/cameligo/LexToken.mll
View File

@ -79,6 +79,7 @@ type t =
| End of Region.t
| False of Region.t
| Fun of Region.t
| Rec of Region.t
| If of Region.t
| In of Region.t
| Let of Region.t
@ -154,6 +155,7 @@ let proj_token = function
| End region -> region, "End"
| False region -> region, "False"
| Fun region -> region, "Fun"
| Rec region -> region, "Rec"
| If region -> region, "If"
| In region -> region, "In"
| Let region -> region, "Let"
@ -213,6 +215,7 @@ let to_lexeme = function
| End _ -> "end"
| False _ -> "false"
| Fun _ -> "fun"
| Rec _ -> "rec"
| If _ -> "if"
| In _ -> "in"
| Let _ -> "let"
@ -250,6 +253,7 @@ let keywords = [
(fun reg -> End reg);
(fun reg -> False reg);
(fun reg -> Fun reg);
(fun reg -> Rec reg);
(fun reg -> If reg);
(fun reg -> In reg);
(fun reg -> Let reg);
@ -291,7 +295,6 @@ let reserved =
|> add "object"
|> add "open"
|> add "private"
|> add "rec"
|> add "sig"
|> add "struct"
|> add "to"
@ -499,6 +502,7 @@ let is_kwd = function
| End _
| False _
| Fun _
| Rec _
| If _
| In _
| Let _

1
src/passes/1-parser/cameligo/ParToken.mly
View File

@ -59,6 +59,7 @@
%token <Region.t> End "end"
%token <Region.t> False "false"
%token <Region.t> Fun "fun"
%token <Region.t> Rec "rec"
%token <Region.t> If "if"
%token <Region.t> In "in"
%token <Region.t> Let "let"

24
src/passes/1-parser/cameligo/Parser.mly
View File

@ -203,14 +203,15 @@ field_decl:
and value = {field_name=$1; colon=$2; field_type=$3}
in {region; value} }
(* Top-level non-recursive definitions *)
(* Top-level definitions *)
let_declaration:
"let" let_binding seq(Attr) {
"let" ioption("rec") let_binding seq(Attr) {
let kwd_let = $1 in
let attributes = $3 in
let binding = $2 in
let value = kwd_let, binding, attributes in
let kwd_rec = $2 in
let attributes = $4 in
let binding = $3 in
let value = kwd_let, kwd_rec, binding, attributes in
let stop = expr_to_region binding.let_rhs in
let region = cover $1 stop
in {region; value} }
@ -453,15 +454,16 @@ case_clause(right_expr):
{pattern=$1; arrow=$2; rhs=$3} }
let_expr(right_expr):
"let" let_binding seq(Attr) "in" right_expr {
"let" ioption("rec") let_binding seq(Attr) "in" right_expr {
let kwd_let = $1
and binding = $2
and attributes = $3
and kwd_in = $4
and body = $5 in
and kwd_rec = $2
and binding = $3
and attributes = $4
and kwd_in = $5
and body = $6 in
let stop = expr_to_region body in
let region = cover kwd_let stop
and value = {kwd_let; binding; kwd_in; body; attributes}
and value = {kwd_let; kwd_rec; binding; kwd_in; body; attributes}
in ELetIn {region; value} }
fun_expr(right_expr):

24
src/passes/1-parser/cameligo/ParserLog.ml
View File

@ -136,8 +136,9 @@ and print_attributes state attributes =
) attributes
and print_statement state = function
Let {value=kwd_let, let_binding, attributes; _} ->
Let {value=kwd_let, kwd_rec, let_binding, attributes; _} ->
print_token state kwd_let "let";
print_token_opt state kwd_rec "rec";
print_let_binding state let_binding;
print_attributes state attributes
| TypeDecl {value={kwd_type; name; eq; type_expr}; _} ->
@ -544,8 +545,9 @@ and print_case_clause state {value; _} =
print_expr state rhs
and print_let_in state {value; _} =
let {kwd_let; binding; kwd_in; body; attributes} = value in
let {kwd_let; kwd_rec; binding; kwd_in; body; attributes} = value in
print_token state kwd_let "let";
print_token_opt state kwd_rec "rec";
print_let_binding state binding;
print_attributes state attributes;
print_token state kwd_in "in";
@ -616,9 +618,14 @@ let rec pp_ast state {decl; _} =
List.iteri (List.length decls |> apply) decls
and pp_declaration state = function
Let {value = (_, let_binding, attr); region} ->
Let {value = (_, kwd_rec, let_binding, attr); region} ->
pp_loc_node state "Let" region;
(match kwd_rec with
| None -> ()
| Some (_) -> pp_node (state#pad 0 0) "rec"
);
pp_let_binding state let_binding attr;
| TypeDecl {value; region} ->
pp_loc_node state "TypeDecl" region;
pp_type_decl state value
@ -854,14 +861,21 @@ and pp_fun_expr state node =
in ()
and pp_let_in state node =
let {binding; body; attributes; _} = node in
let {binding; body; attributes; kwd_rec; _} = node in
let {binders; lhs_type; let_rhs; _} = binding in
let fields = if lhs_type = None then 3 else 4 in
let fields = if kwd_rec = None then fields else fields+1 in
let fields = if attributes = [] then fields else fields+1 in
let arity =
match kwd_rec with
None -> 0
| Some (_) ->
let state = state#pad fields 0 in
pp_node state "rec"; 0 in
let arity =
let state = state#pad fields 0 in
pp_node state "<binders>";
pp_binders state binders; 0 in
pp_binders state binders; arity in
let arity =
match lhs_type with
None -> arity

1636
src/passes/1-parser/cameligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

3
src/passes/1-parser/pascaligo/AST.ml
View File

@ -37,6 +37,7 @@ type kwd_end = Region.t
type kwd_for = Region.t
type kwd_from = Region.t
type kwd_function = Region.t
type kwd_recursive = Region.t
type kwd_if = Region.t
type kwd_in = Region.t
type kwd_is = Region.t
@ -201,6 +202,7 @@ and type_tuple = (type_expr, comma) nsepseq par reg
(* Function and procedure declarations *)
and fun_expr = {
kwd_recursive: kwd_recursive option;
kwd_function : kwd_function;
param : parameters;
colon : colon;
@ -210,6 +212,7 @@ and fun_expr = {
}
and fun_decl = {
kwd_recursive: kwd_recursive option;
kwd_function : kwd_function;
fun_name : variable;
param : parameters;

1
src/passes/1-parser/pascaligo/LexToken.mli
View File

@ -89,6 +89,7 @@ type t =
| For of Region.t (* "for" *)
| From of Region.t (* "from" *)
| Function of Region.t (* "function" *)
| Recursive of Region.t (* "recursive" *)
| If of Region.t (* "if" *)
| In of Region.t (* "in" *)
| Is of Region.t (* "is" *)

4
src/passes/1-parser/pascaligo/LexToken.mll
View File

@ -87,6 +87,7 @@ type t =
| For of Region.t (* "for" *)
| From of Region.t (* "from" *)
| Function of Region.t (* "function" *)
| Recursive of Region.t (* "recursive" *)
| If of Region.t (* "if" *)
| In of Region.t (* "in" *)
| Is of Region.t (* "is" *)
@ -199,6 +200,7 @@ let proj_token = function
| For region -> region, "For"
| From region -> region, "From"
| Function region -> region, "Function"
| Recursive region -> region, "Recursive"
| If region -> region, "If"
| In region -> region, "In"
| Is region -> region, "Is"
@ -289,6 +291,7 @@ let to_lexeme = function
| For _ -> "for"
| From _ -> "from"
| Function _ -> "function"
| Recursive _ -> "recursive"
| If _ -> "if"
| In _ -> "in"
| Is _ -> "is"
@ -361,6 +364,7 @@ let keywords = [
(fun reg -> Or reg);
(fun reg -> Patch reg);
(fun reg -> Record reg);
(fun reg -> Recursive reg);
(fun reg -> Remove reg);
(fun reg -> Set reg);
(fun reg -> Skip reg);

1
src/passes/1-parser/pascaligo/ParToken.mly
View File

@ -57,6 +57,7 @@
%token <Region.t> False "False"
%token <Region.t> For "for"
%token <Region.t> Function "function"
%token <Region.t> Recursive "recursive"
%token <Region.t> From "from"
%token <Region.t> If "if"
%token <Region.t> In "in"

67
src/passes/1-parser/pascaligo/Parser.mly
View File

@ -237,49 +237,52 @@ field_decl:
fun_expr:
"function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $6 in
let region = cover $1 stop
and value = {kwd_function = $1;
param = $2;
colon = $3;
ret_type = $4;
kwd_is = $5;
return = $6}
| ioption ("recursive") "function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $7 in
let region = cover $2 stop
and value = {kwd_recursive= $1;
kwd_function = $2;
param = $3;
colon = $4;
ret_type = $5;
kwd_is = $6;
return = $7}
in {region; value} }
(* Function declarations *)
open_fun_decl:
"function" fun_name parameters ":" type_expr "is"
ioption ("recursive") "function" fun_name parameters ":" type_expr "is"
block "with" expr {
Scoping.check_reserved_name $2;
let stop = expr_to_region $9 in
let region = cover $1 stop
and value = {kwd_function = $1;
fun_name = $2;
param = $3;
colon = $4;
ret_type = $5;
kwd_is = $6;
block_with = Some ($7, $8);
return = $9;
Scoping.check_reserved_name $3;
let stop = expr_to_region $10 in
let region = cover $2 stop
and value = {kwd_recursive= $1;
kwd_function = $2;
fun_name = $3;
param = $4;
colon = $5;
ret_type = $6;
kwd_is = $7;
block_with = Some ($8, $9);
return = $10;
terminator = None;
attributes = None}
in {region; value}
}
| "function" fun_name parameters ":" type_expr "is" expr {
Scoping.check_reserved_name $2;
let stop = expr_to_region $7 in
let region = cover $1 stop
and value = {kwd_function = $1;
fun_name = $2;
param = $3;
colon = $4;
ret_type = $5;
kwd_is = $6;
| ioption ("recursive") "function" fun_name parameters ":" type_expr "is" expr {
Scoping.check_reserved_name $3;
let stop = expr_to_region $8 in
let region = cover $2 stop
and value = {kwd_recursive= $1;
kwd_function = $2;
fun_name = $3;
param = $4;
colon = $5;
ret_type = $6;
kwd_is = $7;
block_with = None;
return = $7;
return = $8;
terminator = None;
attributes = None}
in {region; value} }

21
src/passes/1-parser/pascaligo/ParserLog.ml
View File

@ -218,8 +218,9 @@ and print_fun_decl state {value; _} =
print_terminator state terminator;
and print_fun_expr state {value; _} =
let {kwd_function; param; colon;
let {kwd_recursive; kwd_function; param; colon;
ret_type; kwd_is; return} : fun_expr = value in
print_token_opt state kwd_recursive "recursive";
print_token state kwd_function "function";
print_parameters state param;
print_token state colon ":";
@ -858,20 +859,26 @@ and pp_declaration state = function
and pp_attr_decl state = pp_ne_injection pp_string state
and pp_fun_decl state decl =
let arity = 5 in
let arity, start =
match decl.kwd_recursive with
None -> 5,0
| Some _ ->
let state = state#pad 6 0 in
let () = pp_node state "recursive"
in 6,1 in
let () =
let state = state#pad arity 0 in
let state = state#pad arity start in
pp_ident state decl.fun_name in
let () =
let state = state#pad arity 1 in
let state = state#pad arity (start + 1) in
pp_node state "<parameters>";
pp_parameters state decl.param in
let () =
let state = state#pad arity 2 in
let state = state#pad arity (start + 2) in
pp_node state "<return type>";
pp_type_expr (state#pad 1 0) decl.ret_type in
let () =
let state = state#pad arity 3 in
let state = state#pad arity (start + 3) in
pp_node state "<body>";
let statements =
match decl.block_with with
@ -879,7 +886,7 @@ and pp_fun_decl state decl =
| None -> Instr (Skip Region.ghost), [] in
pp_statements state statements in
let () =
let state = state#pad arity 4 in
let state = state#pad arity (start + 4) in
pp_node state "<return>";
pp_expr (state#pad 1 0) decl.return
in ()

2237
src/passes/1-parser/pascaligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

1
src/passes/1-parser/reasonligo/LexToken.mli
View File

@ -95,6 +95,7 @@ type t =
| False of Region.t
| If of Region.t
| Let of Region.t
| Rec of Region.t
| Switch of Region.t
| Mod of Region.t
| Or of Region.t

6
src/passes/1-parser/reasonligo/LexToken.mll
View File

@ -80,6 +80,7 @@ type t =
| False of Region.t
| If of Region.t
| Let of Region.t
| Rec of Region.t
| Switch of Region.t
| Mod of Region.t
| Or of Region.t
@ -146,6 +147,7 @@ let proj_token = function
| False region -> region, "False"
| If region -> region, "If"
| Let region -> region, "Let"
| Rec region -> region, "Rec"
| Switch region -> region, "Switch"
| Mod region -> region, "Mod"
| NOT region -> region, "!"
@ -197,6 +199,7 @@ let to_lexeme = function
| False _ -> "false"
| If _ -> "if"
| Let _ -> "let"
| Rec _ -> "rec"
| Mod _ -> "mod"
| NOT _ -> "!"
| Or _ -> "or"
@ -232,6 +235,7 @@ let keywords = [
(fun reg -> False reg);
(fun reg -> If reg);
(fun reg -> Let reg);
(fun reg -> Rec reg);
(fun reg -> Switch reg);
(fun reg -> Mod reg);
(fun reg -> Or reg);
@ -273,7 +277,6 @@ let reserved =
|> add "of"
|> add "open"
|> add "private"
|> add "rec"
|> add "sig"
|> add "struct"
|> add "then"
@ -478,6 +481,7 @@ let is_kwd = function
| False _
| If _
| Let _
| Rec _
| Switch _
| Mod _
| Or _

1
src/passes/1-parser/reasonligo/ParToken.mly
View File

@ -59,6 +59,7 @@
%token <Region.t> False "false"
%token <Region.t> If "if"
%token <Region.t> Let "let"
%token <Region.t> Rec "rec"
%token <Region.t> Switch "switch"
%token <Region.t> Mod "mod"
%token <Region.t> Or "or"

22
src/passes/1-parser/reasonligo/Parser.mly
View File

@ -261,14 +261,15 @@ field_decl:
and value = {field_name=$1; colon=$2; field_type=$3}
in {region; value} }
(* Top-level non-recursive definitions *)
(* Top-level definitions *)
let_declaration:
seq(Attr) "let" let_binding {
seq(Attr) "let" ioption("rec") let_binding {
let attributes = $1 in
let kwd_let = $2 in
let binding = $3 in
let value = kwd_let, binding, attributes in
let kwd_rec = $3 in
let binding = $4 in
let value = kwd_let, kwd_rec, binding, attributes in
let stop = expr_to_region binding.let_rhs in
let region = cover $2 stop
in {region; value} }
@ -650,15 +651,16 @@ case_clause(right_expr):
in {region; value} }
let_expr(right_expr):
seq(Attr) "let" let_binding ";" right_expr {
seq(Attr) "let" ioption("rec") let_binding ";" right_expr {
let attributes = $1 in
let kwd_let = $2 in
let binding = $3 in
let kwd_in = $4 in
let body = $5 in
let stop = expr_to_region $5 in
let kwd_rec = $3 in
let binding = $4 in
let kwd_in = $5 in
let body = $6 in
let stop = expr_to_region $6 in
let region = cover $2 stop
and value = {kwd_let; binding; kwd_in; body; attributes}
and value = {kwd_let; kwd_rec; binding; kwd_in; body; attributes}
in ELetIn {region; value} }
disj_expr_level:

1465
src/passes/1-parser/reasonligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

80
src/passes/2-simplify/cameligo.ml
View File

@ -70,6 +70,17 @@ module Errors = struct
fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc)]
in error ~data title message
let untyped_recursive_function var =
let title () = "" in
let message () =
Format.asprintf "\nUntyped recursive functions \
are not supported yet.\n" in
let param_loc = var.Region.region in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ param_loc)]
in error ~data title message
let unsupported_tuple_pattern p =
let title () = "" in
let message () =
@ -334,7 +345,7 @@ let rec simpl_expression :
trace (simplifying_expr t) @@
match t with
Raw.ELetIn e ->
let Raw.{binding; body; attributes; _} = e.value in
let Raw.{kwd_rec; binding; body; attributes; _} = e.value in
let inline = List.exists (fun (a: Raw.attribute) -> a.value = "inline") attributes in
let Raw.{binders; lhs_type; let_rhs; _} = binding in
begin match binders with
@ -382,10 +393,50 @@ let rec simpl_expression :
(chain_let_in tl body)
| [] -> body (* Precluded by corner case assertion above *)
in
if List.length prep_vars = 1
let%bind ty_opt = match ty_opt with
| None -> (match let_rhs with
| EFun {value={binders;lhs_type}} ->
let f_args = nseq_to_list (binders) in
let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in
let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in
let aux acc ty = Option.map (t_function (snd ty)) acc in
ok @@ (List.fold_right' aux lhs_type' ty)
| _ -> ok None
)
| Some t -> ok @@ Some t
in
let%bind ret_expr = if List.length prep_vars = 1
then ok (chain_let_in prep_vars body)
(* Bind the right hand side so we only evaluate it once *)
else ok (e_let_in (rhs_b, ty_opt) false inline rhs' (chain_let_in prep_vars body))
in
let%bind ret_expr = match kwd_rec with
| None -> ok @@ ret_expr
| Some _ ->
match ret_expr.expression_content with
| E_let_in li -> (
let%bind lambda =
let rec aux rhs = match rhs.expression_content with
| E_lambda l -> ok @@ l
| E_ascription a -> aux a.anno_expr
| _ -> fail @@ corner_case "recursive only supported for lambda"
in
aux rhs'
in
let fun_name = fst @@ List.hd prep_vars in
let%bind fun_type = match ty_opt with
| Some t -> ok @@ t
| None -> match rhs'.expression_content with
| E_ascription a -> ok a.type_annotation
| _ -> fail @@ untyped_recursive_function e
in
let expression_content = E_recursive {fun_name;fun_type;lambda} in
let expression_content = E_let_in {li with rhs = {li.rhs with expression_content}} in
ok @@ {ret_expr with expression_content}
)
| _ -> fail @@ corner_case "impossible"
in
ok ret_expr
(* let f p1 ps... = rhs in body *)
| (f, p1 :: ps) ->
@ -630,6 +681,7 @@ and simpl_fun lamb' : expr result =
in
let let_in: Raw.let_in =
{kwd_let= Region.ghost;
kwd_rec= None;
binding= let_in_binding;
kwd_in= Region.ghost;
body= lamb.body;
@ -658,7 +710,8 @@ and simpl_fun lamb' : expr result =
e_lambda ~loc (binder) (Some input_type) output_type (layer_arguments tl)
| [] -> body
in
return @@ layer_arguments params'
let ret_lamb = layer_arguments params' in
return @@ ret_lamb
and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
@ -738,12 +791,11 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
let%bind type_expression = simpl_type_expression type_expr in
ok @@ [loc x @@ Declaration_type (Var.of_name name.value , type_expression)]
| Let x -> (
let (_, let_binding, attributes), _ = r_split x in
let (_, recursive, let_binding, attributes), _ = r_split x in
let inline = List.exists (fun (a: Raw.attribute) -> a.value = "inline") attributes in
let binding = let_binding in
let {binders; lhs_type; let_rhs} = binding in
let%bind (hd, _) =
let (hd, tl) = binders in ok (hd, tl) in
let (hd, _) = binders in
match hd with
| PTuple pt ->
let process_variable (var_pair: pattern * Raw.expr) :
@ -795,11 +847,11 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
in ok @@ decls
| PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } ->
(* Extract parenthetical multi-bind *)
let (wild, _, attributes) = fst @@ r_split x in
let (wild, recursive, _, attributes) = fst @@ r_split x in
simpl_declaration
(Let {
region = x.region;
value = (wild, {binders = (pt, []);
value = (wild, recursive, {binders = (pt, []);
lhs_type = lhs_type;
eq = Region.ghost ;
let_rhs = let_rhs}, attributes)}
@ -840,6 +892,18 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
)
| Some t -> ok @@ Some t
in
let binder = Var.of_name var.value in
let%bind rhs' = match recursive with
None -> ok @@ rhs'
| Some _ -> match rhs'.expression_content with
E_lambda lambda ->
(match lhs_type with
None -> fail @@ untyped_recursive_function var
| Some (lhs_type) ->
let expression_content = E_recursive {fun_name=binder;fun_type=lhs_type;lambda} in
ok @@ {rhs' with expression_content})
| _ -> ok @@ rhs'
in
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
)

73
src/passes/2-simplify/pascaligo.ml
View File

@ -659,7 +659,7 @@ and simpl_fun_decl :
((expression_variable * type_expression option) * expression) result =
fun ~loc x ->
let open! Raw in
let {fun_name; param; ret_type; block_with;
let {kwd_recursive;fun_name; param; ret_type; block_with;
return; attributes} : fun_decl = x in
let inline =
match attributes with
@ -683,11 +683,17 @@ and simpl_fun_decl :
let%bind result =
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let expression : expression = e_lambda ~loc (Var.of_name binder) (Some input_type)
(Some output_type) result in
let type_annotation =
Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
ok ((Var.of_name fun_name.value, type_annotation), expression)
let binder = Var.of_name binder in
let fun_name = Var.of_name fun_name.value in
let fun_type = t_function input_type output_type in
let expression : expression =
e_lambda ~loc binder (Some input_type)(Some output_type) result in
let%bind expression = match kwd_recursive with
None -> ok @@ expression |
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok ((fun_name, Some fun_type), expression)
)
| lst -> (
let lst = npseq_to_list lst in
@ -713,10 +719,16 @@ and simpl_fun_decl :
let%bind result =
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let expression =
e_lambda ~loc binder (Some (input_type)) (Some output_type) result in
let type_annotation = Some (make_t @@ T_arrow {type1=input_type; type2=output_type}) in
ok ((Var.of_name fun_name.value, type_annotation), expression)
let fun_name = Var.of_name fun_name.value in
let fun_type = t_function input_type output_type in
let expression : expression =
e_lambda ~loc binder (Some input_type)(Some output_type) result in
let%bind expression = match kwd_recursive with
None -> ok @@ expression |
Some _ -> ok @@ e_recursive ~loc fun_name fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok ((fun_name, Some fun_type), expression)
)
)
@ -724,7 +736,7 @@ and simpl_fun_expression :
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
fun ~loc x ->
let open! Raw in
let {param;ret_type;return;_} : fun_expr = x in
let {kwd_recursive;param;ret_type;return} : fun_expr = x in
let statements = [] in
(match param.value.inside with
a, [] -> (
@ -737,10 +749,14 @@ and simpl_fun_expression :
let%bind result =
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let expression : expression = e_lambda ~loc (Var.of_name binder) (Some input_type)
(Some output_type) result in
let type_annotation = Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
ok (type_annotation , expression)
let binder = Var.of_name binder in
let fun_type = t_function input_type output_type in
let expression = match kwd_recursive with
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
| Some _ -> e_recursive ~loc binder fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok (Some fun_type , expression)
)
| lst -> (
let lst = npseq_to_list lst in
@ -765,10 +781,13 @@ and simpl_fun_expression :
let%bind result =
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let expression =
e_lambda ~loc binder (Some (input_type)) (Some output_type) result in
let type_annotation = Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
ok (type_annotation , expression)
let fun_type = t_function input_type output_type in
let expression = match kwd_recursive with
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
| Some _ -> e_recursive ~loc binder fun_type
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
in
ok (Some fun_type , expression)
)
)
@ -1202,8 +1221,8 @@ and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun w
in
let init_rec = e_tuple [store_mutable_variable @@ captured_name_list] in
let restore = fun expr -> List.fold_right aux captured_name_list expr in
let continue_expr = e_constant C_CONTINUE [for_body] in
let stop_expr = e_constant C_STOP [e_variable binder] in
let continue_expr = e_constant C_FOLD_CONTINUE [for_body] in
let stop_expr = e_constant C_FOLD_STOP [e_variable binder] in
let aux_func =
e_lambda binder None None @@
restore @@
@ -1229,10 +1248,11 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
let%bind bound = simpl_expression fi.bound in
let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in
let step = e_int 1 in
let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in
let ctrl =
e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ])
(e_let_in (binder, None) false false (e_update (e_variable binder) "1" var)
(e_variable binder))
e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ]) @@
e_let_in (binder, None) false false (e_update (e_variable binder) "1" var)@@
continue_expr
in
(* Modify the body loop*)
let%bind for_body = simpl_block fi.block.value in
@ -1247,11 +1267,10 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
let restore = fun expr -> List.fold_right aux captured_name_list expr in
(*Prep the lambda for the fold*)
let continue_expr = e_constant C_CONTINUE [restore(for_body)] in
let stop_expr = e_constant C_STOP [e_variable binder] in
let stop_expr = e_constant C_FOLD_STOP [e_variable binder] in
let aux_func = e_lambda binder None None @@
e_let_in (it,Some t_int) false false (e_accessor (e_variable binder) "1") @@
e_cond cond continue_expr (stop_expr) in
e_cond cond (restore for_body) (stop_expr) in
(* Make the fold_while en precharge the vakye *)
let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in

11
src/passes/3-self_ast_simplified/helpers.ml
View File

@ -56,6 +56,9 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = self res let_result in
ok res
)
| E_recursive { lambda={result=e;_}; _} ->
let%bind res = self init' e in
ok res
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with
@ -156,6 +159,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind result = self result in
return @@ E_lambda { binder ; input_type ; output_type ; result }
)
| E_recursive { fun_name; fun_type; lambda} ->
let%bind result = self lambda.result in
let lambda = {lambda with result} in
return @@ E_recursive { fun_name; fun_type; lambda}
| E_constant c -> (
let%bind args = bind_map_list self c.arguments in
return @@ E_constant {c with arguments=args}
@ -295,6 +302,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,result) = self init' result in
ok ( res, return @@ E_lambda { binder ; input_type ; output_type ; result })
)
| E_recursive { fun_name; fun_type; lambda} ->
let%bind (res, result) = self init' lambda.result in
let lambda = {lambda with result} in
ok ( res, return @@ E_recursive { fun_name; fun_type; lambda})
| E_constant c -> (
let%bind (res,args) = bind_fold_map_list self init' c.arguments in
ok (res, return @@ E_constant {c with arguments=args})

8
src/passes/4-typer-new/solver.ml
View File

@ -291,6 +291,14 @@ module Wrap = struct
C_equation (result' , P_variable whole_expr)
] @ rhs_tv_opt', whole_expr
let recursive : T.type_expression -> (constraints * T.type_variable) =
fun fun_type ->
let fun_type = type_expression_to_type_value fun_type in
let whole_expr = Core.fresh_type_variable () in
O.[
C_equation (fun_type, P_variable whole_expr)
], whole_expr
let assign : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
fun v e ->
let v' = type_expression_to_type_value v in

63
src/passes/4-typer-new/typer.ml
View File

@ -797,26 +797,16 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
(* | _ -> ( … ) *)
| E_lambda {
binder ;
input_type ;
output_type ;
result ;
} -> (
let%bind input_type' = bind_map_option (evaluate_type e) input_type in
let%bind output_type' = bind_map_option (evaluate_type e) output_type in
let fresh : O.type_expression = t_variable (Wrap.fresh_binder ()) () in
let binder = fst binder in
let e' = Environment.add_ez_binder (binder) fresh e in
let%bind (result , state') = type_expression e' state result in
let () = Printf.printf "this does not make use of the typed body, this code sounds buggy." in
let wrapped = Wrap.lambda fresh input_type' output_type' in
return_wrapped
(E_lambda {binder = binder; result}) (* TODO: is the type of the entire lambda enough to access the input_type=fresh; ? *)
| E_lambda lambda ->
let%bind (lambda,state',wrapped) = type_lambda e state lambda in
return_wrapped (E_lambda lambda) (* TODO: is the type of the entire lambda enough to access the input_type=fresh; ? *)
state' wrapped
)
| E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = evaluate_type e fun_type in
let e = Environment.add_ez_binder fun_name fun_type e in
let%bind (lambda,state,_) = type_lambda e state lambda in
let wrapped = Wrap.recursive fun_type in
return_wrapped (E_recursive {fun_name;fun_type;lambda}) state wrapped
| E_constant {cons_name=name; arguments=lst} ->
let () = ignore (name , lst) in
@ -838,7 +828,22 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
type_constant name tv_lst tv_opt ae.location in
return (E_constant (name' , lst')) tv
*)
and type_lambda e state {
binder ;
input_type ;
output_type ;
result ;
} =
let%bind input_type' = bind_map_option (evaluate_type e) input_type in
let%bind output_type' = bind_map_option (evaluate_type e) output_type in
let fresh : O.type_expression = t_variable (Solver.Wrap.fresh_binder ()) () in
let e' = Environment.add_ez_binder (binder) fresh e in
let%bind (result , state') = type_expression e' state result in
let () = Printf.printf "this does not make use of the typed body, this code sounds buggy." in
let wrapped = Solver.Wrap.lambda fresh input_type' output_type' in
ok (({binder;result}:O.lambda),state',wrapped)
(* Advanced *)
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
@ -1040,12 +1045,10 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind f' = untype_expression expr1 in
let%bind arg' = untype_expression expr2 in
return (e_application f' arg')
| E_lambda {binder; result} -> (
let%bind io = get_t_function e.type_expression in
let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression result in
return (e_lambda (binder) (Some input_type) (Some output_type) result)
)
| E_lambda lambda ->
let%bind lambda = untype_lambda e.type_expression lambda in
let {binder;input_type;output_type;result} = lambda in
return (e_lambda (binder) (input_type) (output_type) result)
| E_constructor {constructor; element} ->
let%bind p' = untype_expression element in
let Constructor n = constructor in
@ -1092,6 +1095,16 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind rhs = untype_expression rhs in
let%bind result = untype_expression let_result in
return (e_let_in (let_binder , (Some tv)) false inline rhs result)
| E_recursive {fun_name; fun_type; lambda} ->
let%bind lambda = untype_lambda fun_type lambda in
let%bind fun_type = untype_type_expression fun_type in
return @@ e_recursive fun_name fun_type lambda
and untype_lambda ty {binder; result} : I.lambda result =
let%bind io = get_t_function ty in
let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression result in
ok ({binder;input_type = Some input_type; output_type = Some output_type; result}: I.lambda)
(*
Tranform a Ast_typed matching into an ast_simplified matching

97
src/passes/4-typer-old/typer.ml
View File

@ -613,45 +613,12 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
ok (t_big_map key_type value_type ())
in
return (E_big_map lst') tv
| E_lambda {
binder ;
input_type ;
output_type ;
result ;
} -> (
let%bind input_type =
let%bind input_type =
(* Hack to take care of let_in introduced by `simplify/cameligo.ml` in ECase's hack *)
let default_action e () = fail @@ (needs_annotation e "the returned value") in
match input_type with
| Some ty -> ok ty
| None -> (
match result.expression_content with
| I.E_let_in li -> (
match li.rhs.expression_content with
| I.E_variable name when name = (fst binder) -> (
match snd li.let_binder with
| Some ty -> ok ty
| None -> default_action li.rhs ()
)
| _ -> default_action li.rhs ()
)
| _ -> default_action result ()
)
in
evaluate_type e input_type in
let%bind output_type =
bind_map_option (evaluate_type e) output_type
in
let binder = fst binder in
let e' = Environment.add_ez_binder binder input_type e in
let%bind body = type_expression' ?tv_opt:output_type e' result in
let output_type = body.type_expression in
return (E_lambda {binder; result=body}) (t_function input_type output_type ())
)
| E_lambda lambda ->
let%bind (lambda, lambda_type) = type_lambda e lambda in
return (E_lambda lambda ) lambda_type
| E_constant {cons_name=( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ;
arguments=[
( { expression_content = (I.E_lambda { binder = (lname, None) ;
( { expression_content = (I.E_lambda { binder = lname ;
input_type = None ;
output_type = None ;
result }) ;
@ -683,7 +650,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
return (E_constant {cons_name=opname';arguments=lst'}) tv
| E_constant {cons_name=C_FOLD_WHILE as opname;
arguments = [
( { expression_content = (I.E_lambda { binder = (lname, None) ;
( { expression_content = (I.E_lambda { binder = lname ;
input_type = None ;
output_type = None ;
result }) ;
@ -773,6 +740,11 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_declaration (let_binder) rhs e in
let%bind let_result = type_expression' e' let_result in
return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
| E_recursive {fun_name; fun_type; lambda} ->
let%bind fun_type = evaluate_type e fun_type in
let e' = Environment.add_ez_binder fun_name fun_type e in
let%bind (lambda,_) = type_lambda e' lambda in
return (E_recursive {fun_name;fun_type;lambda}) fun_type
| E_ascription {anno_expr; type_annotation} ->
let%bind tv = evaluate_type e type_annotation in
let%bind expr' = type_expression' ~tv_opt:tv e anno_expr in
@ -788,6 +760,42 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
| Some tv' -> O.assert_type_expression_eq (tv' , type_annotation) in
ok {expr' with type_expression=type_annotation}
and type_lambda e {
binder ;
input_type ;
output_type ;
result ;
} =
let%bind input_type =
let%bind input_type =
(* Hack to take care of let_in introduced by `simplify/cameligo.ml` in ECase's hack *)
let default_action e () = fail @@ (needs_annotation e "the returned value") in
match input_type with
| Some ty -> ok ty
| None -> (
match result.expression_content with
| I.E_let_in li -> (
match li.rhs.expression_content with
| I.E_variable name when name = (binder) -> (
match snd li.let_binder with
| Some ty -> ok ty
| None -> default_action li.rhs ()
)
| _ -> default_action li.rhs ()
)
| _ -> default_action result ()
)
in
evaluate_type e input_type in
let%bind output_type =
bind_map_option (evaluate_type e) output_type
in
let e' = Environment.add_ez_binder binder input_type e in
let%bind body = type_expression' ?tv_opt:output_type e' result in
let output_type = body.type_expression in
ok (({binder; result=body}:O.lambda),(t_function input_type output_type ()))
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
let%bind typer = Operators.Typer.constant_typers name in
@ -820,9 +828,11 @@ let untype_literal (l:O.literal) : I.literal result =
| Literal_operation s -> ok (Literal_operation s)
let rec untype_expression (e:O.expression) : (I.expression) result =
untype_expression_content e.type_expression e.expression_content
and untype_expression_content ty (ec:O.expression_content) : (I.expression) result =
let open I in
let return e = ok e in
match e.expression_content with
match ec with
| E_literal l ->
let%bind l = untype_literal l in
return (e_literal l)
@ -836,7 +846,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind arg' = untype_expression expr2 in
return (e_application f' arg')
| E_lambda {binder ; result} -> (
let%bind io = get_t_function e.type_expression in
let%bind io = get_t_function ty in
let%bind (input_type , output_type) = bind_map_pair untype_type_expression io in
let%bind result = untype_expression result in
return (e_lambda (binder) (Some input_type) (Some output_type) result)
@ -883,7 +893,12 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind tv = untype_type_expression rhs.type_expression in
let%bind rhs = untype_expression rhs in
let%bind result = untype_expression let_result in
return (I.e_let_in (let_binder , (Some tv)) false inline rhs result)
return (e_let_in (let_binder , (Some tv)) false inline rhs result)
| E_recursive {fun_name;fun_type; lambda} ->
let%bind fun_type = untype_type_expression fun_type in
let%bind unty_expr= untype_expression_content ty @@ E_lambda lambda in
let lambda = match unty_expr.expression_content with I.E_lambda l -> l | _ -> failwith "impossible case" in
return @@ e_recursive fun_name fun_type lambda
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
let open I in

21
src/passes/5-self_ast_typed/helpers.ml
View File

@ -25,6 +25,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res
)
| E_lambda { binder = _ ; result = e }
| E_recursive {lambda= {result=e}}
| E_constructor {element=e} -> (
let%bind res = self init' e in
ok res
@ -148,6 +149,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind result = self result in
return @@ E_lambda { binder ; result }
)
| E_recursive { fun_name; fun_type; lambda = {binder;result}} -> (
let%bind result = self result in
return @@ E_recursive { fun_name; fun_type; lambda = {binder;result}}
)
| E_constant c -> (
let%bind args = bind_map_list self c.arguments in
return @@ E_constant {c with arguments=args}
@ -172,9 +177,9 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some, te) }
)
| Match_tuple ((names , e), _) -> (
| Match_tuple ((names , e), te) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple ((names , e'), [])
ok @@ Match_tuple ((names , e'), te)
)
| Match_variant (lst, te) -> (
let aux ((a , b) , e) =
@ -188,9 +193,9 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
and map_program : mapper -> program -> program result = fun m p ->
let aux = fun (x : declaration) ->
match x with
| Declaration_constant (v , e , i, env) -> (
| Declaration_constant (n , e , i, env) -> (
let%bind e' = map_expression m e in
ok (Declaration_constant (v , e' , i, env))
ok (Declaration_constant (n , e' , i, env))
)
in
bind_map_list (bind_map_location aux) p
@ -260,6 +265,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,result) = self init' result in
ok ( res, return @@ E_lambda { binder ; result })
)
| E_recursive { fun_name; fun_type; lambda={binder;result}} -> (
let%bind (res,result) = self init' result in
ok (res, return @@ E_recursive {fun_name; fun_type; lambda={binder;result}})
)
| E_constant c -> (
let%bind (res,args) = bind_fold_map_list self init' c.arguments in
ok (res, return @@ E_constant {c with arguments=args})
@ -283,9 +292,9 @@ and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_exp
let%bind (init, some) = fold_map_expression f init some in
ok @@ (init, Match_option { match_none ; match_some = (name , some, te) })
)
| Match_tuple ((names , e), _) -> (
| Match_tuple ((names , e), te) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple ((names , e'), []))
ok @@ (init, Match_tuple ((names , e'), te))
)
| Match_variant (lst, te) -> (
let aux init ((a , b) , e) =

0
src/passes/5-self_ast_typed/main.ml Normal file
View File

13
src/passes/5-self_ast_typed/self_ast_typed.ml
View File

@ -1,6 +1,8 @@
open Trace
let all_passes = []
let all_passes = [
Tail_recursion.peephole_expression
]
let contract_passes = [
Contract_passes.self_typing ;
@ -22,3 +24,12 @@ let all_contract main_name prg =
} in
let all_p = List.map (fun pass -> Helpers.fold_map_program pass data) contract_passes in
bind_chain_ignore_acc all_p prg
let all = [
Tail_recursion.peephole_expression
]
let map_expression = Helpers.map_expression
let fold_expression = Helpers.fold_expression
let fold_map_expression = Helpers.fold_map_expression

108
src/passes/5-self_ast_typed/tail_recursion.ml Normal file
View File

@ -0,0 +1,108 @@
open Ast_typed
open Trace
module Errors = struct
let recursive_call_is_only_allowed_as_the_last_operation name loc () =
let title = (thunk ("Recursion must be achieved through tail-calls only")) in
let message () = "" in
let data = [
("function" , fun () -> Format.asprintf "%a" PP.expression_variable name);
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
end
open Errors
let rec check_recursive_call : expression_variable -> bool -> expression -> unit result = fun n final_path e ->
match e.expression_content with
| E_literal _ -> ok ()
| E_constant c ->
let%bind _ = bind_map_list (check_recursive_call n false) c.arguments in
ok ()
| E_variable v -> (
let%bind _ = trace_strong (recursive_call_is_only_allowed_as_the_last_operation n e.location) @@
Assert.assert_true (final_path || n <> v) in
ok ()
)
| E_application {expr1;expr2} ->
let%bind _ = check_recursive_call n final_path expr1 in
let%bind _ = check_recursive_call n false expr2 in
ok ()
| E_lambda {result;_} ->
let%bind _ = check_recursive_call n final_path result in
ok ()
| E_recursive { fun_name; lambda} ->
let%bind _ = check_recursive_call fun_name true lambda.result in
ok ()
| E_let_in {rhs;let_result;_} ->
let%bind _ = check_recursive_call n false rhs in
let%bind _ = check_recursive_call n final_path let_result in
ok ()
| E_constructor {element;_} ->
let%bind _ = check_recursive_call n false element in
ok ()
| E_matching {matchee;cases} ->
let%bind _ = check_recursive_call n false matchee in
let%bind _ = check_recursive_call_in_matching n final_path cases in
ok ()
| E_record elm ->
let es = LMap.to_list elm in
let%bind _ = bind_map_list (check_recursive_call n false) es in
ok ()
| E_record_accessor {expr;_} ->
let%bind _ = check_recursive_call n false expr in
ok ()
| E_record_update {record;update;_} ->
let%bind _ = check_recursive_call n false record in
let%bind _ = check_recursive_call n false update in
ok ()
| E_map eel | E_big_map eel->
let aux (e1,e2) =
let%bind _ = check_recursive_call n false e1 in
let%bind _ = check_recursive_call n false e2 in
ok ()
in
let%bind _ = bind_map_list aux eel in
ok ()
| E_list el | E_set el ->
let%bind _ = bind_map_list (check_recursive_call n false) el in
ok ()
| E_look_up (e1,e2) ->
let%bind _ = check_recursive_call n false e1 in
let%bind _ = check_recursive_call n false e2 in
ok ()
and check_recursive_call_in_matching = fun n final_path c ->
match c with
| Match_bool {match_true;match_false} ->
let%bind _ = check_recursive_call n final_path match_true in
let%bind _ = check_recursive_call n final_path match_false in
ok ()
| Match_list {match_nil;match_cons=(_,_,e,_)} ->
let%bind _ = check_recursive_call n final_path match_nil in
let%bind _ = check_recursive_call n final_path e in
ok ()
| Match_option {match_none; match_some=(_,e,_)} ->
let%bind _ = check_recursive_call n final_path match_none in
let%bind _ = check_recursive_call n final_path e in
ok ()
| Match_tuple ((_,e),_) ->
let%bind _ = check_recursive_call n final_path e in
ok ()
| Match_variant (l,_) ->
let aux (_,e) =
let%bind _ = check_recursive_call n final_path e in
ok ()
in
let%bind _ = bind_map_list aux l in
ok ()
let peephole_expression : expression -> expression result = fun e ->
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_recursive {fun_name; lambda} as e-> (
let%bind _ = check_recursive_call fun_name true lambda.result in
return e
)
| e -> return e

15
src/passes/6-interpreter/interpreter.ml
View File

@ -80,8 +80,8 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
| ( C_IS_NAT , [ V_Ct (C_int a') ] ) ->
if a' > 0 then return_some @@ V_Ct (C_nat a')
else return_none ()
| ( C_CONTINUE , [ v ] ) -> ok @@ v_pair (v_bool true , v)
| ( C_STOP , [ v ] ) -> ok @@ v_pair (v_bool false , v)
| ( C_FOLD_CONTINUE , [ v ] ) -> ok @@ v_pair (v_bool true , v)
| ( C_FOLD_STOP , [ v ] ) -> ok @@ v_pair (v_bool false , v)
| ( C_ASSERTION , [ v ] ) ->
let%bind pass = is_true v in
if pass then return_ct @@ C_unit
@ -272,18 +272,23 @@ and eval : Ast_typed.expression -> env -> value result
match term.expression_content with
| E_application ({expr1 = f; expr2 = args}) -> (
let%bind f' = eval f env in
let%bind args' = eval args env in
match f' with
| V_Func_val (arg_names, body, f_env) ->
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, arg_names, body, f_env) ->
let f_env' = Env.extend f_env (arg_names, args') in
let f_env'' = Env.extend f_env' (fun_name, f') in
eval body f_env''
| _ -> simple_fail "trying to apply on something that is not a function"
)
| E_lambda {binder; result;} ->
ok @@ V_Func_val (binder,result,env)
| E_let_in { let_binder; rhs; let_result; _} ->
| E_let_in {let_binder ; rhs; let_result} -> (
let%bind rhs' = eval rhs env in
eval let_result (Env.extend env (let_binder,rhs'))
)
| E_map kvlist | E_big_map kvlist ->
let%bind kvlist' = bind_map_list
(fun kv -> bind_map_pair (fun (el:Ast_typed.expression) -> eval el env) kv)
@ -371,6 +376,8 @@ and eval : Ast_typed.expression -> env -> value result
| _ -> simple_fail "not yet supported case"
(* ((ctor,name),body) *)
)
| E_recursive {fun_name; fun_type=_; lambda} ->
ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env)
| E_look_up _ ->
let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in
simple_fail serr

130
src/passes/6-transpiler/transpiler.ml
View File

@ -102,6 +102,15 @@ them. please report this to the developers." in
] in
error ~data title content
let unsupported_recursive_function expression_variable =
let title () = "unsupported recursive function yet" in
let content () = "only fuction with one variable are supported" in
let data = [
("value" , fun () -> Format.asprintf "%a" AST.PP.expression_variable expression_variable) ;
] in
error ~data title content
end
open Errors
@ -379,6 +388,8 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
| E_lambda l ->
let%bind io = AST.get_t_function ae.type_expression in
transpile_lambda l io
| E_recursive r ->
transpile_recursive r
| E_list lst -> (
let%bind t =
trace_strong (corner_case ~loc:__LOC__ "not a list") @@
@ -518,6 +529,125 @@ and transpile_lambda l (input_type , output_type) =
let closure = E_closure { binder; body = result'} in
ok @@ Combinators.Expression.make_tpl (closure , tv)
and transpile_recursive {fun_name; fun_type; lambda} =
let rec map_lambda : AST.expression_variable -> type_value -> AST.expression -> (expression * expression_variable list) result = fun fun_name loop_type e ->
match e.expression_content with
E_lambda {binder;result} ->
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 false e in
ok @@ (res, [])
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 ->
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 shadowed m ty |
E_application {expr1;expr2} -> (
match expr1.expression_content,shadowed with
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 |
_ ->
let%bind expr = transpile_annotated_expression e in
ok @@ Expression.make (E_constant {cons_name=C_LOOP_STOP;arguments=[expr]}) loop_type
) |
_ ->
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 -> 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 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 shadowed match_none in
let%bind (tv' , s') =
let%bind tv' = transpile_type tv 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'))
| Match_list {
match_nil ;
match_cons = ((hd_name) , (tl_name), match_cons, ty) ;
} -> (
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 shadowed match_cons in
ok (((hd_name , ty') , (tl_name , ty')) , match_cons')
in
return @@ E_if_cons (expr , nil , cons)
)
| Match_variant (lst , variant) -> (
let%bind tree =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum variant in
let%bind tree' = match tree with
| Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
| Full x -> ok x in
let%bind tree'' =
let rec aux t =
match (t : _ Append_tree.t') with
| Leaf (name , tv) ->
let%bind tv' = transpile_type tv in
ok (`Leaf name , tv')
| Node {a ; b} ->
let%bind a' = aux a in
let%bind b' = aux b in
let tv' = Mini_c.t_union (None, snd a') (None, snd b') in
ok (`Node (a' , b') , tv')
in aux tree'
in
let rec aux top t =
match t with
| ((`Leaf constructor_name) , tv) -> (
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 shadowed body in
return @@ E_let_in ((name , tv) , false , top , body')
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
let%bind a_ty = get_t_left tv in
let left_var = Var.fresh ~name:"left" () in
let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in
ok ((left_var , a_ty) , e)
in
let%bind b' =
let%bind b_ty = get_t_right tv in
let right_var = Var.fresh ~name:"right" () in
let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in
ok ((right_var , b_ty) , e)
in
return @@ E_if_left (top , a' , b')
in
trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
aux expr tree''
)
| AST.Match_tuple _ -> failwith "match_tuple not supported"
in
let%bind fun_type = transpile_type fun_type in
let%bind (input_type,output_type) = get_t_function fun_type in
let loop_type = t_union (None, input_type) (None, output_type) in
let%bind (body,binder) = map_lambda fun_name loop_type lambda.result in
let binder = lambda.binder::binder in
let%bind binder = match binder with hd::[] -> ok @@ hd | _ -> fail @@ unsupported_recursive_function fun_name in
let expr = Expression.make_tpl (E_variable binder, input_type) in
let body = Expression.make (E_iterator (C_LOOP_LEFT, ((lambda.binder, loop_type),body), expr)) output_type in
ok @@ Expression.make (E_closure {binder;body}) fun_type
let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
match d with
| Declaration_constant (name,expression, inline, _) ->

21
src/passes/8-compiler/compiler_program.ml
View File

@ -50,13 +50,22 @@ let rec get_operator : constant' -> type_value -> expression list -> predicate r
let%bind ty' = Mini_c.get_t_option ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_constant @@ prim ~children:[m_ty] I_NONE
)
| C_NIL -> (
let%bind ty' = Mini_c.get_t_list ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_unary @@ prim ~children:[m_ty] I_NIL
)
| C_LOOP_CONTINUE -> (
let%bind (_,ty) = get_t_or ty in
let%bind m_ty = Compiler_type.type_ ty in
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 @@ prim ~children:[m_ty] I_RIGHT
)
| C_SET_EMPTY -> (
let%bind ty' = Mini_c.get_t_set ty in
let%bind m_ty = Compiler_type.type_ ty' in
@ -397,6 +406,16 @@ and translate_expression (expr:expression) (env:environment) : michelson result
]) in
return code
)
| C_LOOP_LEFT -> (
let%bind (_, ty) = get_t_or (snd v) in
let%bind m_ty = Compiler_type.type_ ty in
let%bind code = ok (seq [
expr' ;
prim ~children:[m_ty] I_LEFT;
i_loop_left body';
]) in
return code
)
| s -> (
let iter = Format.asprintf "iter %a" PP.constant s in
let error = error (thunk "bad iterator") (thunk iter) in

22
src/passes/operators/operators.ml
View File

@ -349,11 +349,11 @@ module Simplify = struct
(* Loop module *)
| "Loop.fold_while" -> ok C_FOLD_WHILE
| "Loop.resume" -> ok C_CONTINUE
| "continue" -> ok C_CONTINUE (* Deprecated *)
| "Loop.stop" -> ok C_STOP
| "stop" -> ok C_STOP (* Deprecated *)
| "Loop.fold_while" -> ok C_FOLD_WHILE (* Deprecated *)
| "Loop.resume" -> ok C_FOLD_CONTINUE
| "continue" -> ok C_FOLD_CONTINUE (* Deprecated *)
| "Loop.stop" -> ok C_FOLD_STOP
| "stop" -> ok C_FOLD_STOP (* Deprecated *)
(* Others *)
@ -515,8 +515,8 @@ module Typer = struct
| C_FAILWITH -> ok @@ t_failwith ;
(* LOOPS *)
| C_FOLD_WHILE -> ok @@ t_fold_while ;
| C_CONTINUE -> ok @@ t_continuation ;
| C_STOP -> ok @@ t_continuation ;
| C_FOLD_CONTINUE -> ok @@ t_continuation ;
| C_FOLD_STOP -> ok @@ t_continuation ;
(* MATH *)
| C_NEG -> ok @@ t_neg ;
| C_ABS -> ok @@ t_abs ;
@ -1115,8 +1115,8 @@ module Typer = struct
| C_FAILWITH -> ok @@ failwith_ ;
(* LOOPS *)
| C_FOLD_WHILE -> ok @@ fold_while ;
| C_CONTINUE -> ok @@ continue ;
| C_STOP -> ok @@ stop ;
| C_FOLD_CONTINUE -> ok @@ continue ;
| C_FOLD_STOP -> ok @@ stop ;
(* MATH *)
| C_NEG -> ok @@ neg ;
| C_ABS -> ok @@ abs ;
@ -1248,8 +1248,8 @@ module Compiler = struct
| C_MAP_ADD -> ok @@ simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]
| C_MAP_UPDATE -> ok @@ simple_ternary @@ prim I_UPDATE
| C_FOLD_WHILE -> ok @@ simple_binary @@ seq [i_swap ; (i_push (prim T_bool) (prim D_True));prim ~children:[seq [dip i_dup; i_exec; i_unpair]] I_LOOP ;i_swap ; i_drop]
| C_CONTINUE -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_True)); i_pair]
| C_STOP -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_False)); i_pair]
| C_FOLD_CONTINUE -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_True)); i_pair]
| C_FOLD_STOP -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_False)); i_pair]
| C_SIZE -> ok @@ simple_unary @@ prim I_SIZE
| C_FAILWITH -> ok @@ simple_unary @@ prim I_FAILWITH
| C_ASSERT_INFERRED -> ok @@ simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])

15
src/stages/ast_simplified/PP.ml
View File

@ -11,7 +11,9 @@ let expression_variable ppf (ev : expression_variable) : unit =
let rec expression ppf (e : expression) =
match e.expression_content with
expression_content ppf e.expression_content
and expression_content ppf (ec : expression_content) =
match ec with
| E_literal l ->
literal ppf l
| E_variable n ->
@ -40,16 +42,23 @@ let rec expression ppf (e : expression) =
| E_look_up (ds, ind) ->
fprintf ppf "(%a)[%a]" expression ds expression ind
| E_lambda {binder; input_type; output_type; result} ->
fprintf ppf "lambda (%a:%a) : %a return %a" option_type_name binder
fprintf ppf "lambda (%a:%a) : %a return %a"
expression_variable binder
(PP_helpers.option type_expression)
input_type
(PP_helpers.option type_expression)
output_type expression result
| E_matching {matchee; cases; _} ->
fprintf ppf "match %a with %a" expression matchee (matching expression)
fprintf ppf "match %a with %a"
expression matchee (matching expression)
cases
| E_let_in { let_binder ; mut; rhs ; let_result; inline } ->
fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result
| E_recursive { fun_name; fun_type; lambda} ->
fprintf ppf "rec (%a:%a => %a )"
expression_variable fun_name
type_expression fun_type
expression_content (E_lambda lambda)
| E_skip ->
fprintf ppf "skip"
| E_ascription {anno_expr; type_annotation} ->

3
src/stages/ast_simplified/combinators.ml
View File

@ -178,11 +178,12 @@ let e_lambda ?loc (binder : expression_variable)
(result : expression)
: expression =
location_wrap ?loc @@ E_lambda {
binder = (binder , input_type) ;
binder = binder;
input_type = input_type ;
output_type = output_type ;
result ;
}
let e_recursive ?loc fun_name fun_type lambda = location_wrap ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_assign_with_let ?loc var access_path expr =

1
src/stages/ast_simplified/combinators.mli
View File

@ -106,6 +106,7 @@ val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> ty
val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_update : ?loc:Location.t -> expression -> string -> expression -> expression
val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)

2
src/stages/ast_simplified/misc.ml
View File

@ -182,7 +182,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
| (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _)
| (E_record_accessor _, _)
| (E_recursive _,_) | (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _)
| (E_skip, _) -> simple_fail "comparing not a value"

9
src/stages/ast_simplified/types.ml
View File

@ -35,6 +35,7 @@ and expression_content =
| E_application of application
| E_lambda of lambda
| E_let_in of let_in
| E_recursive of recursive
| E_skip
(* Variant *)
| E_constructor of constructor (* For user defined constructors *)
@ -60,7 +61,7 @@ and constant =
and application = {expr1: expression; expr2: expression}
and lambda =
{ binder: expression_variable * type_expression option
{ binder: expression_variable
; input_type: type_expression option
; output_type: type_expression option
; result: expression }
@ -72,6 +73,12 @@ and let_in =
; let_result: expression
; inline: bool }
and recursive = {
fun_name : expression_variable;
fun_type : type_expression;
lambda : lambda;
}
and constructor = {constructor: constructor'; element: expression}
and accessor = {expr: expression; label: label}

10
src/stages/ast_typed/PP.ml
View File

@ -11,7 +11,10 @@ let expression_variable ppf (ev : expression_variable) : unit =
let rec expression ppf (e : expression) =
match e.expression_content with
expression_content ppf e.expression_content
and expression_content ppf (ec: expression_content) =
match ec with
| E_literal l ->
literal ppf l
| E_variable n ->
@ -47,6 +50,11 @@ let rec expression ppf (e : expression) =
| E_let_in {let_binder; rhs; let_result; inline} ->
fprintf ppf "let %a = %a%a in %a" expression_variable let_binder expression
rhs option_inline inline expression let_result
| E_recursive { fun_name;fun_type; lambda} ->
fprintf ppf "rec (%a:%a => %a )"
expression_variable fun_name
type_expression fun_type
expression_content (E_lambda lambda)
and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b

11
src/stages/ast_typed/combinators.ml
View File

@ -168,6 +168,17 @@ let get_t_function (t:type_expression) : (type_expression * type_expression) res
| T_arrow {type1;type2} -> ok (type1,type2)
| _ -> simple_fail "not a function"
let get_t_function_full (t:type_expression) : (type_expression * type_expression) result =
let%bind _ = get_t_function t in
let rec aux n t = match t.type_content with
| T_arrow {type1;type2} ->
let (l, o) = aux (n+1) type2 in
((Label (string_of_int n),type1)::l,o)
| _ -> ([],t)
in
let (input,output) = aux 0 t in
ok @@ (t_record (LMap.of_list input) (),output)
let get_t_sum (t:type_expression) : type_expression constructor_map result = match t.type_content with
| T_sum m -> ok m
| _ -> fail @@ Errors.not_a_x_type "sum" t ()

1
src/stages/ast_typed/combinators.mli
View File

@ -62,6 +62,7 @@ val get_t_key_hash : type_expression -> unit result
val get_t_tuple : type_expression -> type_expression list result
val get_t_pair : type_expression -> ( type_expression * type_expression ) result
val get_t_function : type_expression -> ( type_expression * type_expression ) result
val get_t_function_full : type_expression -> ( type_expression * type_expression ) result
val get_t_sum : type_expression -> type_expression constructor_map result
val get_t_record : type_expression -> type_expression label_map result
val get_t_map : type_expression -> ( type_expression * type_expression ) result

5
src/stages/ast_typed/misc.ml
View File

@ -221,6 +221,9 @@ module Free_variables = struct
union
(expression b' let_result)
(self rhs)
| E_recursive {fun_name;lambda;_} ->
let b' = union (singleton fun_name) b in
expression_content b' @@ E_lambda lambda
and lambda : bindings -> lambda -> bindings = fun b l ->
let b' = union (singleton l.binder) b in
@ -529,7 +532,7 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result =
| E_set _, _ ->
fail @@ different_values_because_different_types "set vs. non-set" a b
| (E_literal _, _) | (E_variable _, _) | (E_application _, _)
| (E_lambda _, _) | (E_let_in _, _)
| (E_lambda _, _) | (E_let_in _, _) | (E_recursive _, _)
| (E_record_accessor _, _) | (E_record_update _,_)
| (E_look_up _, _) | (E_matching _, _)
-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b

11
src/stages/ast_typed/misc_smart.ml
View File

@ -45,9 +45,11 @@ module Captured_variables = struct
let empty : bindings = []
let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings result = fun b ae ->
let rec expression : bindings -> expression -> bindings result = fun b e ->
expression_content b e.environment e.expression_content
and expression_content : bindings -> full_environment -> expression_content -> bindings result = fun b env ec ->
let self = expression b in
match ae.expression_content with
match ec with
| E_lambda l -> ok @@ Free_variables.lambda empty l
| E_literal _ -> ok empty
| E_constant {arguments;_} ->
@ -56,7 +58,7 @@ module Captured_variables = struct
| E_variable name -> (
let%bind env_element =
trace_option (simple_error "missing var in env") @@
Environment.get_opt name ae.environment in
Environment.get_opt name env in
match env_element.definition with
| ED_binder -> ok empty
| ED_declaration {expr=_ ; free_variables=_} -> simple_fail "todo"
@ -92,6 +94,9 @@ module Captured_variables = struct
| E_let_in li ->
let b' = union (singleton li.let_binder) b in
expression b' li.let_result
| E_recursive r ->
let b' = union (singleton r.fun_name) b in
expression_content b' env @@ E_lambda r.lambda
and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor' * expression_variable) * a) -> bindings result = fun f b ((_,n),c) ->
f (union (singleton n) b) c

7
src/stages/ast_typed/types.ml
View File

@ -41,6 +41,7 @@ and expression_content =
| E_application of application
| E_lambda of lambda
| E_let_in of let_in
| E_recursive of recursive
(* Variant *)
| E_constructor of constructor (* For user defined constructors *)
| E_matching of matching
@ -76,6 +77,12 @@ and let_in = {
inline : inline ;
}
and recursive = {
fun_name : expression_variable;
fun_type : type_expression;
lambda : lambda;
}
and constructor = {
constructor: constructor';
element: expression ;

7
src/stages/common/PP.ml
View File

@ -56,8 +56,11 @@ let constant ppf : constant' -> unit = function
| C_ITER -> fprintf ppf "ITER"
| C_FOLD -> fprintf ppf "FOLD"
| C_FOLD_WHILE -> fprintf ppf "FOLD_WHILE"
| C_CONTINUE -> fprintf ppf "CONTINUE"
| C_STOP -> fprintf ppf "STOP"
| C_FOLD_CONTINUE -> fprintf ppf "CONTINUE"
| C_FOLD_STOP -> fprintf ppf "STOP"
| C_LOOP_LEFT -> fprintf ppf "LOOP_LEFT"
| C_LOOP_CONTINUE -> fprintf ppf "LOOP_CONTINUE"
| C_LOOP_STOP -> fprintf ppf "LOOP_STOP"
(* MATH *)
| C_NEG -> fprintf ppf "NEG"
| C_ABS -> fprintf ppf "ABS"

7
src/stages/common/types.ml
View File

@ -197,8 +197,11 @@ and constant' =
(* Loops *)
| C_ITER
| C_FOLD_WHILE
| C_CONTINUE
| C_STOP
| C_FOLD_CONTINUE
| C_FOLD_STOP
| C_LOOP_LEFT
| C_LOOP_CONTINUE
| C_LOOP_STOP
| C_FOLD
(* MATH *)
| C_NEG

1
src/stages/ligo_interpreter/PP.ml
View File

@ -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]" @@

1
src/stages/ligo_interpreter/types.ml
View File

@ -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 * expression_variable * Ast_typed.expression * env)
| V_Ct of constant_val
| V_List of value list
| V_Record of value label_map

7
src/stages/mini_c/PP.ml
View File

@ -149,8 +149,11 @@ and constant ppf : constant' -> unit = function
(* Loops *)
| C_FOLD -> fprintf ppf "FOLD"
| C_FOLD_WHILE -> fprintf ppf "FOLD_WHILE"
| C_CONTINUE -> fprintf ppf "CONTINUE"
| C_STOP -> fprintf ppf "STOP"
| C_FOLD_CONTINUE -> fprintf ppf "CONTINUE"
| C_FOLD_STOP -> fprintf ppf "STOP"
| C_LOOP_LEFT -> fprintf ppf "LOOP_LEFT"
| C_LOOP_CONTINUE -> fprintf ppf "LOOP_CONTINUE"
| C_LOOP_STOP -> fprintf ppf "LOOP_STOP"
| C_ITER -> fprintf ppf "ITER"
(* MATH *)
| C_NEG -> fprintf ppf "NEG"

6
src/stages/typesystem/misc.ml
View File

@ -164,6 +164,12 @@ module Substitution = struct
let%bind rhs = s_expression ~substs rhs in
let%bind let_result = s_expression ~substs let_result in
ok @@ T.E_let_in { let_binder; rhs; let_result; inline }
| T.E_recursive { fun_name; fun_type; lambda} ->
let%bind fun_name = s_variable ~substs fun_name in
let%bind fun_type = s_type_expression ~substs fun_type in
let%bind sec = s_expression_content ~substs (T.E_lambda lambda) in
let lambda = match sec with E_lambda l -> l | _ -> failwith "impossible case" in
ok @@ T.E_recursive { fun_name; fun_type; lambda}
| T.E_constructor {constructor;element} ->
let%bind constructor = s_constructor ~substs constructor in
let%bind element = s_expression ~substs element in

1
src/stages/typesystem/shorthands.ml
View File

@ -48,6 +48,7 @@ let (=>) tc ty = (tc , ty)
let (-->) arg ret = P_constant (C_arrow , [arg; ret])
let option t = P_constant (C_option , [t])
let pair a b = P_constant (C_record , [a; b])
let sum a b = P_constant (C_variant, [a; b])
let map k v = P_constant (C_map , [k; v])
let unit = P_constant (C_unit , [])
let list t = P_constant (C_list , [t])

12
src/test/contracts/interpret_test.mligo
View File

@ -232,3 +232,15 @@ let set_mem =
Set.mem 1 s,
Set.mem 4 s,
Set.mem 1 (Set.empty : int set)
let recursion_let_rec_in =
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)
let rec sum_rec ((n,acc):int * int) : int =
if (n < 1) then acc else sum_rec (n-1, acc+n)
let top_level_recursion = sum_rec (10,0)

31
src/test/contracts/loop.mligo
View File

@ -1,10 +1,9 @@
(* Test functional iterators in CameLIGO *)
let aux_simple (i : int) : bool * int =
if i < 100 then Loop.resume (i + 1) else Loop.stop i
let rec aux_simple (i : int) : int =
if i < 100 then aux_simple (i + 1) else i
let counter_simple (n : int) : int =
Loop.fold_while aux_simple n
let counter_simple (n : int) : int = aux_simple n
type sum_aggregator = {
counter : int;
@ -13,25 +12,23 @@ type sum_aggregator = {
let counter (n : int) : int =
let initial : sum_aggregator = {counter=0; sum=0} in
let aggregate = fun (prev : sum_aggregator) ->
let rec aggregate : sum_aggregator -> int = fun (prev: sum_aggregator) ->
if prev.counter <= n then
Loop.resume {counter = prev.counter + 1;
aggregate {counter = prev.counter + 1;
sum = prev.counter + prev.sum}
else
Loop.stop {counter = prev.counter; sum = prev.sum} in
let out : sum_aggregator =
Loop.fold_while aggregate initial
in out.sum
prev.sum
in
aggregate initial
let aux_nest (prev : sum_aggregator) : bool * sum_aggregator =
let rec aux_nest (prev : sum_aggregator) : int =
if prev.counter < 100 then
let sum : int =
prev.sum + Loop.fold_while aux_simple prev.counter
in Loop.resume {counter = prev.counter + 1; sum = sum}
let sum = prev.sum + (aux_simple prev.counter) in
aux_nest {counter = prev.counter + 1; sum = sum}
else
Loop.stop {counter = prev.counter; sum = prev.sum}
prev.sum
let counter_nest (n : int) : int =
let initial : sum_aggregator = {counter=0; sum=0} in
let out : sum_aggregator = Loop.fold_while aux_nest initial
in out.sum
let out = aux_nest initial
in out

26
src/test/contracts/loop.religo
View File

@ -1,9 +1,9 @@
/* Test loops in ReasonLIGO */
let aux_simple = (i : int) : (bool, int) =>
if (i < 100) { Loop.resume (i + 1); } else { Loop.stop (i); };
let rec aux_simple = (i : int) : int =>
if (i < 100) { aux_simple (i + 1); } else { i; };
let counter_simple = (n : int) : int => Loop.fold_while (aux_simple, n);
let counter_simple = (n : int) : int => aux_simple (n);
type sum_aggregator = {
counter : int,
@ -12,30 +12,28 @@ type sum_aggregator = {
let counter = (n : int) : int => {
let initial : sum_aggregator = {counter: 0, sum: 0};
let aggregate = (prev : sum_aggregator) =>
let rec aggregate = (prev : sum_aggregator):int =>
if (prev.counter <= n) {
Loop.resume ({counter : prev.counter + 1,
aggregate ({counter : prev.counter + 1,
sum : prev.counter + prev.sum});
} else {
Loop.stop ({counter: prev.counter, sum: prev.sum});
prev.sum;
};
let out : sum_aggregator =
Loop.fold_while (aggregate, initial);
out.sum;
aggregate (initial);
};
let aux_nest = (prev : sum_aggregator) : (bool, sum_aggregator) =>
let rec aux_nest = (prev : sum_aggregator) : sum_aggregator =>
if (prev.counter < 100) {
let sum : int =
prev.sum + Loop.fold_while (aux_simple, prev.counter);
Loop.resume ({counter: prev.counter + 1,
prev.sum + aux_simple (prev.counter);
aux_nest ({counter: prev.counter + 1,
sum: sum});
} else {
Loop.stop ({counter: prev.counter, sum: prev.sum});
({counter: prev.counter, sum: prev.sum});
};
let counter_nest = (n : int) : int => {
let initial : sum_aggregator = {counter: 0, sum: 0};
let out : sum_aggregator = Loop.fold_while (aux_nest, initial);
let out : sum_aggregator = aux_nest (initial);
out.sum;
};

3
src/test/contracts/negative/error_no_tail_recursive_function.mligo Normal file
View File

@ -0,0 +1,3 @@
let rec unvalid (n:int):int =
let res = unvalid (n) in
res + 1

7
src/test/contracts/recursion.ligo Normal file
View File

@ -0,0 +1,7 @@
// Test while loops in PascaLIGO
recursive function sum (const n : int; const acc: int) : int is
if n<1 then acc else sum(n-1,acc+n)
recursive function fibo (const n: int; const n_1: int; const n_0 :int) : int is
if n<2 then n_1 else fibo(n-1,n_1+n_0,n_1)

7
src/test/contracts/recursion.mligo Normal file
View File

@ -0,0 +1,7 @@
// Test while loops in PascaLIGO
let rec sum ((n,acc):int * int) : int =
if (n < 1) then acc else sum (n-1, acc+n)
let rec fibo ((n,n_1,n_0):int*int*int) : int =
if (n < 2) then n_1 else fibo (n-1, n_1 + n_0, n_1)

7
src/test/contracts/recursion.religo Normal file
View File

@ -0,0 +1,7 @@
// Test while loops in PascaLIGO
let rec sum = ((n, acc) : (int,int)): int =>
if (n < 1) {acc;} else {sum ((n-1,acc+n));};
let rec fibo = ((n, n_1, n_0) : (int,int,int)): int =>
if (n < 2) {n_1;} else {fibo ((n-1,n_1+n_0,n_1));};

43
src/test/integration_tests.ml
View File

@ -1493,6 +1493,46 @@ let assert_religo () : unit result =
let%bind _ = expect_eq program "main" (make_input true) make_expected in
ok ()
let recursion_ligo () : unit result =
let%bind program = type_file "./contracts/recursion.ligo" in
let%bind _ =
let make_input = e_pair (e_int 10) (e_int 0) in
let make_expected = e_int 55 in
expect_eq program "sum" make_input make_expected
in
let%bind _ =
let make_input = e_tuple [(e_int 10); (e_int 1); (e_int 1)] in
let make_expected = e_int 89 in
expect_eq program "fibo" make_input make_expected
in ok ()
let recursion_mligo () : unit result =
let%bind program = mtype_file "./contracts/recursion.mligo" in
let%bind _ =
let make_input = e_pair (e_int 10) (e_int 0) in
let make_expected = e_int 55 in
expect_eq program "sum" make_input make_expected
in
let%bind _ =
let make_input = e_tuple [(e_int 10); (e_int 1); (e_int 1)] in
let make_expected = e_int 89 in
expect_eq program "fibo" make_input make_expected
in ok ()
let recursion_religo () : unit result =
let%bind program = retype_file "./contracts/recursion.religo" in
let%bind _ =
let make_input = e_pair (e_int 10) (e_int 0) in
let make_expected = e_int 55 in
expect_eq program "sum" make_input make_expected
in
let%bind _ =
let make_input = e_tuple [(e_int 10); (e_int 1); (e_int 1)] in
let make_expected = e_int 89 in
expect_eq program "fibo" make_input make_expected
in ok ()
let guess_string_mligo () : unit result =
let%bind program = type_file "./contracts/guess_string.mligo" in
let make_input = fun n -> e_pair (e_int n) (e_int 42) in
@ -2407,6 +2447,9 @@ let main = test_suite "Integration (End to End)" [
test "failwith ligo" failwith_ligo ;
test "failwith mligo" failwith_mligo ;
test "assert mligo" assert_mligo ;
test "recursion (ligo)" recursion_ligo ;
test "recursion (mligo)" recursion_mligo ;
test "recursion (religo)" recursion_religo ;
(* test "guess string mligo" guess_string_mligo ; WIP? *)
test "lambda mligo" lambda_mligo ;
test "lambda religo" lambda_religo ;

8
test.mligo Normal file
View File

@ -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)

2
vendors/ligo-utils/tezos-utils/x_michelson.ml vendored
View File

@ -78,6 +78,8 @@ let i_dug n : michelson = prim ~children:[Int (0 , Z.of_int n)] I_DUG
let i_unpair = seq [i_dup ; i_car ; dip i_cdr]
let i_unpiar = seq [i_dup ; i_cdr ; dip i_car]
let i_loop_left body = prim ~children:[seq[body; dip i_drop]] I_LOOP_LEFT
let rec strip_annots : michelson -> michelson = function
| Seq(l, s) -> Seq(l, List.map strip_annots s)
| Prim (l, p, lst, _) -> Prim (l, p, List.map strip_annots lst, [])