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

Merge branch 'inline-attribute' into 'dev'

Browse Source 
Add attributes for CameLIGO, ReasonLIGO and PascaLIGO.

See merge request ligolang/ligo!279
This commit is contained in:
Sander 2020-01-16 19:36:04 +00:00
commit 6ce1ca4fcd
53 changed files with 565 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -119,6 +119,7 @@ type type_name = string reg
type field_name = string reg
type type_constr = string reg
type constr = string reg
type attribute = string reg
(* Parentheses *)
@ -139,8 +140,10 @@ type t = {
and ast = t
and attributes = attribute list
and declaration =
Let of (kwd_let * let_binding) reg
Let of (kwd_let * let_binding * attributes) reg
| TypeDecl of type_decl reg
(* Non-recursive values *)
@ -360,18 +363,19 @@ and 'a case_clause = {
}
and let_in = {
kwd_let : kwd_let;
binding : let_binding;
kwd_in : kwd_in;
body : expr
kwd_let : kwd_let;
binding : let_binding;
kwd_in : kwd_in;
body : expr;
attributes : attributes
}
and fun_expr = {
kwd_fun : kwd_fun;
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
arrow : arrow;
body : expr
kwd_fun : kwd_fun;
binders : pattern nseq;
lhs_type : (colon * type_expr) option;
arrow : arrow;
body : expr;
}
and cond_expr = {

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

@ -85,6 +85,7 @@ type t =
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr2 of string Region.reg
(* Keywords *)
@ -137,6 +138,7 @@ type ident_err = Reserved_name
type nat_err = Invalid_natural
| Non_canonical_zero_nat
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
type kwd_err = Invalid_keyword
val mk_int : lexeme -> Region.t -> (token, int_err) result
@ -148,6 +150,8 @@ val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token
val mk_attr : lexeme -> Region.t -> (token, attr_err) result
val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result
val eof : Region.t -> token
(* Predicates *)

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

@ -69,6 +69,7 @@ type t =
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr2 of string Region.reg
(* Keywords *)
@ -163,10 +164,9 @@ let proj_token = function
| True region -> region, "True"
| Type region -> region, "Type"
| With region -> region, "With"
| C_None region -> region, "C_None"
| C_Some region -> region, "C_Some"
| Attr2 Region.{region; value} -> region, sprintf "Attr2 %s" value
| EOF region -> region, "EOF"
let to_lexeme = function
@ -226,7 +226,7 @@ let to_lexeme = function
| C_None _ -> "None"
| C_Some _ -> "Some"
| Attr2 a -> a.Region.value
| EOF _ -> ""
let to_string token ?(offsets=true) mode =
@ -418,6 +418,8 @@ let eof region = EOF region
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
let mk_sym lexeme region =
match lexeme with
(* Lexemes in common with all concrete syntaxes *)
@ -465,6 +467,14 @@ let mk_ident lexeme region =
let mk_constr lexeme region =
Lexing.from_string lexeme |> scan_constr region lexicon
(* Attributes *)
let mk_attr _lexeme _region =
Error Invalid_attribute
let mk_attr2 lexeme region =
Ok (Attr2 { value = lexeme; region })
(* Predicates *)
let is_string = function

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

@ -12,6 +12,7 @@
%token <(string * Z.t) Region.reg> Mutez "<mutez>"
%token <string Region.reg> Ident "<ident>"
%token <string Region.reg> Constr "<constr>"
%token <string Region.reg> Attr2 "<attr>"
(* Symbols *)

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

@ -202,12 +202,13 @@ field_decl:
(* Top-level non-recursive definitions *)
let_declaration:
"let" let_binding {
let kwd_let = $1 in
let binding = $2 in
let value = kwd_let, binding in
let stop = expr_to_region binding.let_rhs in
let region = cover $1 stop
"let" let_binding seq(Attr2) {
let kwd_let = $1 in
let attributes = $3 in
let binding = $2 in
let value = kwd_let, binding, attributes in
let stop = expr_to_region binding.let_rhs in
let region = cover $1 stop
in {region; value} }
let_binding:
@ -443,25 +444,27 @@ case_clause(right_expr):
pattern "->" right_expr { {pattern=$1; arrow=$2; rhs=$3} }
let_expr(right_expr):
"let" let_binding "in" right_expr {
let kwd_let = $1
and binding = $2
and kwd_in = $3
and body = $4 in
let stop = expr_to_region body in
let region = cover kwd_let stop
and value = {kwd_let; binding; kwd_in; body}
"let" let_binding seq(Attr2) "in" right_expr {
let kwd_let = $1
and binding = $2
and attributes = $3
and kwd_in = $4
and body = $5 in
let stop = expr_to_region body in
let region = cover kwd_let stop
and value = {kwd_let; binding; kwd_in; body; attributes}
in ELetIn {region; value} }
fun_expr(right_expr):
"fun" nseq(irrefutable) "->" right_expr {
let stop = expr_to_region $4 in
let region = cover $1 stop in
let value = {kwd_fun = $1;
binders = $2;
lhs_type = None;
arrow = $3;
body = $4}
let value = {kwd_fun = $1;
binders = $2;
lhs_type = None;
arrow = $3;
body = $4
}
in EFun {region; value} }
disj_expr_level:

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

@ -128,10 +128,18 @@ let rec print_tokens state {decl;eof} =
Utils.nseq_iter (print_statement state) decl;
print_token state eof "EOF"
and print_attributes state attributes =
List.iter (
fun ({value = attribute; region}) ->
let attribute_formatted = sprintf "[@%s]" attribute in
print_token state region attribute_formatted
) attributes
and print_statement state = function
Let {value=kwd_let, let_binding; _} ->
Let {value=kwd_let, let_binding, attributes; _} ->
print_token state kwd_let "let";
print_let_binding state let_binding
print_let_binding state let_binding;
print_attributes state attributes
| TypeDecl {value={kwd_type; name; eq; type_expr}; _} ->
print_token state kwd_type "type";
print_var state name;
@ -530,9 +538,10 @@ and print_case_clause state {value; _} =
print_expr state rhs
and print_let_in state {value; _} =
let {kwd_let; binding; kwd_in; body} = value in
let {kwd_let; binding; kwd_in; body; attributes} = value in
print_token state kwd_let "let";
print_let_binding state binding;
print_attributes state attributes;
print_token state kwd_in "in";
print_expr state body
@ -601,9 +610,9 @@ let rec pp_ast state {decl; _} =
List.iteri (List.length decls |> apply) decls
and pp_declaration state = function
Let {value; region} ->
Let {value = (_, let_binding, _); region} ->
pp_loc_node state "Let" region;
pp_let_binding state (snd value)
pp_let_binding state let_binding
| TypeDecl {value; region} ->
pp_loc_node state "TypeDecl" region;
pp_type_decl state value

11
src/passes/1-parser/pascaligo.ml
View File

@ -56,6 +56,15 @@ module Errors = struct
] in
error ~data title message
let detached_attributes (attrs: AST.attributes) =
let title () = "detached attributes" in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ attrs.region)
] in
error ~data title message
let parser_error source (start: Lexing.position) (end_: Lexing.position) lexbuf =
let title () = "parser error" in
let file = if source = "" then
@ -135,6 +144,8 @@ let parse (parser: 'a parser) source lexbuf =
fail @@ (duplicate_variant name)
| SyntaxError.Error (Reserved_name name) ->
fail @@ (reserved_name name)
| SyntaxError.Error (Detached_attributes attrs) ->
fail @@ (detached_attributes attrs)
| Parser.Error ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in

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

@ -109,6 +109,7 @@ type field_name = string reg
type map_name = string reg
type set_name = string reg
type constr = string reg
type attribute = string reg
(* Parentheses *)
@ -143,6 +144,8 @@ type t = {
and ast = t
and attributes = attribute list reg
and declaration =
TypeDecl of type_decl reg
| ConstDecl of const_decl reg
@ -155,7 +158,8 @@ and const_decl = {
const_type : type_expr;
equal : equal;
init : expr;
terminator : semi option
terminator : semi option;
attributes : attributes;
}
(* Type declarations *)
@ -212,7 +216,8 @@ and fun_decl = {
kwd_is : kwd_is;
block_with : (block reg * kwd_with) option;
return : expr;
terminator : semi option
terminator : semi option;
attributes : attributes;
}
and parameters = (param_decl, semi) nsepseq par reg
@ -268,7 +273,7 @@ and var_decl = {
var_type : type_expr;
assign : assign;
init : expr;
terminator : semi option
terminator : semi option;
}
and instruction =

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

@ -70,42 +70,43 @@ type t =
(* Keywords *)
| And of Region.t (* "and" *)
| Begin of Region.t (* "begin" *)
| BigMap of Region.t (* "big_map" *)
| Block of Region.t (* "block" *)
| Case of Region.t (* "case" *)
| Const of Region.t (* "const" *)
| Contains of Region.t (* "contains" *)
| Else of Region.t (* "else" *)
| End of Region.t (* "end" *)
| False of Region.t (* "False" *)
| For of Region.t (* "for" *)
| From of Region.t (* "from" *)
| Function of Region.t (* "function" *)
| If of Region.t (* "if" *)
| In of Region.t (* "in" *)
| Is of Region.t (* "is" *)
| List of Region.t (* "list" *)
| Map of Region.t (* "map" *)
| Mod of Region.t (* "mod" *)
| Nil of Region.t (* "nil" *)
| Not of Region.t (* "not" *)
| Of of Region.t (* "of" *)
| Or of Region.t (* "or" *)
| Patch of Region.t (* "patch" *)
| Record of Region.t (* "record" *)
| Remove of Region.t (* "remove" *)
| Set of Region.t (* "set" *)
| Skip of Region.t (* "skip" *)
| Then of Region.t (* "then" *)
| To of Region.t (* "to" *)
| True of Region.t (* "True" *)
| Type of Region.t (* "type" *)
| Unit of Region.t (* "Unit" *)
| Var of Region.t (* "var" *)
| While of Region.t (* "while" *)
| With of Region.t (* "with" *)
| And of Region.t (* "and" *)
| Attributes of Region.t (* "attributes" *)
| Begin of Region.t (* "begin" *)
| BigMap of Region.t (* "big_map" *)
| Block of Region.t (* "block" *)
| Case of Region.t (* "case" *)
| Const of Region.t (* "const" *)
| Contains of Region.t (* "contains" *)
| Else of Region.t (* "else" *)
| End of Region.t (* "end" *)
| False of Region.t (* "False" *)
| For of Region.t (* "for" *)
| From of Region.t (* "from" *)
| Function of Region.t (* "function" *)
| If of Region.t (* "if" *)
| In of Region.t (* "in" *)
| Is of Region.t (* "is" *)
| List of Region.t (* "list" *)
| Map of Region.t (* "map" *)
| Mod of Region.t (* "mod" *)
| Nil of Region.t (* "nil" *)
| Not of Region.t (* "not" *)
| Of of Region.t (* "of" *)
| Or of Region.t (* "or" *)
| Patch of Region.t (* "patch" *)
| Record of Region.t (* "record" *)
| Remove of Region.t (* "remove" *)
| Set of Region.t (* "set" *)
| Skip of Region.t (* "skip" *)
| Then of Region.t (* "then" *)
| To of Region.t (* "to" *)
| True of Region.t (* "True" *)
| Type of Region.t (* "type" *)
| Unit of Region.t (* "Unit" *)
| Var of Region.t (* "var" *)
| While of Region.t (* "while" *)
| With of Region.t (* "with" *)
(* Data constructors *)
@ -138,6 +139,7 @@ type ident_err = Reserved_name
type nat_err = Invalid_natural
| Non_canonical_zero_nat
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
type kwd_err = Invalid_keyword
val mk_int : lexeme -> Region.t -> (token, int_err) result
@ -149,6 +151,8 @@ val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token
val mk_attr : lexeme -> Region.t -> (token, attr_err) result
val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result
val eof : Region.t -> token
(* Predicates *)

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

@ -68,42 +68,43 @@ type t =
(* Keywords *)
| And of Region.t (* "and" *)
| Begin of Region.t (* "begin" *)
| BigMap of Region.t (* "big_map" *)
| Block of Region.t (* "block" *)
| Case of Region.t (* "case" *)
| Const of Region.t (* "const" *)
| Contains of Region.t (* "contains" *)
| Else of Region.t (* "else" *)
| End of Region.t (* "end" *)
| False of Region.t (* "False" *)
| For of Region.t (* "for" *)
| From of Region.t (* "from" *)
| Function of Region.t (* "function" *)
| If of Region.t (* "if" *)
| In of Region.t (* "in" *)
| Is of Region.t (* "is" *)
| List of Region.t (* "list" *)
| Map of Region.t (* "map" *)
| Mod of Region.t (* "mod" *)
| Nil of Region.t (* "nil" *)
| Not of Region.t (* "not" *)
| Of of Region.t (* "of" *)
| Or of Region.t (* "or" *)
| Patch of Region.t (* "patch" *)
| Record of Region.t (* "record" *)
| Remove of Region.t (* "remove" *)
| Set of Region.t (* "set" *)
| Skip of Region.t (* "skip" *)
| Then of Region.t (* "then" *)
| To of Region.t (* "to" *)
| True of Region.t (* "True" *)
| Type of Region.t (* "type" *)
| Unit of Region.t (* "Unit" *)
| Var of Region.t (* "var" *)
| While of Region.t (* "while" *)
| With of Region.t (* "with" *)
| And of Region.t (* "and" *)
| Attributes of Region.t (* "attributes" *)
| Begin of Region.t (* "begin" *)
| BigMap of Region.t (* "big_map" *)
| Block of Region.t (* "block" *)
| Case of Region.t (* "case" *)
| Const of Region.t (* "const" *)
| Contains of Region.t (* "contains" *)
| Else of Region.t (* "else" *)
| End of Region.t (* "end" *)
| False of Region.t (* "False" *)
| For of Region.t (* "for" *)
| From of Region.t (* "from" *)
| Function of Region.t (* "function" *)
| If of Region.t (* "if" *)
| In of Region.t (* "in" *)
| Is of Region.t (* "is" *)
| List of Region.t (* "list" *)
| Map of Region.t (* "map" *)
| Mod of Region.t (* "mod" *)
| Nil of Region.t (* "nil" *)
| Not of Region.t (* "not" *)
| Of of Region.t (* "of" *)
| Or of Region.t (* "or" *)
| Patch of Region.t (* "patch" *)
| Record of Region.t (* "record" *)
| Remove of Region.t (* "remove" *)
| Set of Region.t (* "set" *)
| Skip of Region.t (* "skip" *)
| Then of Region.t (* "then" *)
| To of Region.t (* "to" *)
| True of Region.t (* "True" *)
| Type of Region.t (* "type" *)
| Unit of Region.t (* "Unit" *)
| Var of Region.t (* "var" *)
| While of Region.t (* "while" *)
| With of Region.t (* "with" *)
(* Data constructors *)
@ -175,6 +176,7 @@ let proj_token = function
(* Keywords *)
| And region -> region, "And"
| Attributes region -> region, "Attributes"
| Begin region -> region, "Begin"
| BigMap region -> region, "BigMap"
| Block region -> region, "Block"
@ -215,7 +217,7 @@ let proj_token = function
| C_None region -> region, "C_None"
| C_Some region -> region, "C_Some"
(* Virtual tokens *)
| EOF region -> region, "EOF"
@ -264,6 +266,7 @@ let to_lexeme = function
(* Keywords *)
| And _ -> "and"
| Attributes _ -> "attributes"
| Begin _ -> "begin"
| BigMap _ -> "big_map"
| Block _ -> "block"
@ -321,6 +324,7 @@ let to_region token = proj_token token |> fst
let keywords = [
(fun reg -> And reg);
(fun reg -> Attributes reg);
(fun reg -> Begin reg);
(fun reg -> BigMap reg);
(fun reg -> Block reg);
@ -485,6 +489,8 @@ let eof region = EOF region
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
let mk_sym lexeme region =
match lexeme with
(* Lexemes in common with all concrete syntaxes *)
@ -531,6 +537,14 @@ let mk_ident lexeme region =
let mk_constr lexeme region =
Lexing.from_string lexeme |> scan_constr region lexicon
(* Attributes *)
let mk_attr _lexeme _region =
Error Invalid_attribute
let mk_attr2 _lexeme _region =
Error Invalid_attribute
(* Predicates *)
let is_string = function
@ -551,6 +565,7 @@ let is_ident = function
let is_kwd = function
And _
| Attributes _
| Begin _
| BigMap _
| Block _

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

@ -45,6 +45,7 @@
(* Keywords *)
%token <Region.t> And "and"
%token <Region.t> Attributes "attributes"
%token <Region.t> Begin "begin"
%token <Region.t> BigMap "big_map"
%token <Region.t> Block "block"

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

@ -6,6 +6,39 @@
open Region
open AST
type statement_attributes_mixed =
PInstr of instruction
| PData of data_decl
| PAttributes of attributes
let attributes_to_statement (statement, statements) =
if (List.length statements = 0) then
match statement with
| PInstr i -> Instr i, []
| PData d -> Data d, []
| PAttributes a ->
let open! SyntaxError in
raise (Error (Detached_attributes a))
else (
let statements = (Region.ghost, statement) :: statements in
let rec inner result = function
| (t, PData (LocalConst const)) :: (_, PAttributes a) :: rest ->
inner (result @ [(t, Data (LocalConst {const with value = {const.value with attributes = a}}))]) rest
| (t, PData (LocalFun func)) :: (_, PAttributes a) :: rest ->
inner (result @ [(t, Data (LocalFun {func with value = {func.value with attributes = a}}))]) rest
| (t, PData d) :: rest ->
inner (result @ [(t, Data d)]) rest
| (t, PInstr i) :: rest ->
inner (result @ [(t, Instr i)]) rest
| (_, PAttributes _) :: rest ->
inner result rest
| [] ->
result
in
let result = inner [] statements in
(snd (List.hd result), List.tl result)
)
(* END HEADER *)
%}
@ -112,7 +145,7 @@ contract:
declaration:
type_decl { TypeDecl $1 }
| const_decl { ConstDecl $1 }
| fun_decl { FunDecl $1 }
| fun_decl { FunDecl $1 }
(* Type declarations *)
@ -225,6 +258,7 @@ field_decl:
and value = {field_name=$1; colon=$2; field_type=$3}
in {region; value} }
fun_expr:
"function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $6 in
@ -234,7 +268,8 @@ fun_expr:
colon = $3;
ret_type = $4;
kwd_is = $5;
return = $6}
return = $6
}
in {region; value} }
(* Function declarations *)
@ -254,7 +289,8 @@ open_fun_decl:
kwd_is = $6;
block_with = Some ($7, $8);
return = $9;
terminator = None}
terminator = None;
attributes = {value = []; region = Region.ghost}}
in {region; value} }
| "function" fun_name parameters ":" type_expr "is" expr {
let fun_name = SyntaxError.check_reserved_name $2 in
@ -268,12 +304,15 @@ open_fun_decl:
kwd_is = $6;
block_with = None;
return = $7;
terminator = None}
terminator = None;
attributes = {value = []; region = Region.ghost}}
in {region; value} }
fun_decl:
open_fun_decl ";"? {
{$1 with value = {$1.value with terminator=$2}} }
open_fun_decl semi_attributes {
let attributes, terminator = $2 in
{$1 with value = {$1.value with terminator = terminator; attributes = attributes}}
}
parameters:
par(nsepseq(param_decl,";")) {
@ -311,7 +350,7 @@ block:
let statements, terminator = $2 in
let region = cover $1 $3
and value = {opening = Begin $1;
statements;
statements = attributes_to_statement statements;
terminator;
closing = End $3}
in {region; value}
@ -320,14 +359,15 @@ block:
let statements, terminator = $3 in
let region = cover $1 $4
and value = {opening = Block ($1,$2);
statements;
statements = attributes_to_statement statements;
terminator;
closing = Block $4}
in {region; value} }
statement:
instruction { Instr $1 }
| open_data_decl { Data $1 }
instruction { PInstr $1 }
| open_data_decl { PData $1 }
| attributes { PAttributes $1 }
open_data_decl:
open_const_decl { LocalConst $1 }
@ -344,9 +384,11 @@ open_const_decl:
const_type;
equal;
init;
terminator = None}
terminator = None;
attributes = {value = []; region = Region.ghost}}
in {region; value} }
open_var_decl:
"var" unqualified_decl(":=") {
let name, colon, var_type, assign, init, stop = $2 in
@ -357,7 +399,8 @@ open_var_decl:
var_type;
assign;
init;
terminator = None}
terminator = None;
}
in {region; value} }
unqualified_decl(OP):
@ -366,9 +409,23 @@ unqualified_decl(OP):
let region = expr_to_region $5
in var, $2, $3, $4, $5, region }
attributes:
"attributes" "[" nsepseq(String,";") "]" {
let region = cover $1 $4 in
let value = (Utils.nsepseq_to_list $3) in
{region; value}
}
semi_attributes:
/* empty */ { {value = []; region = Region.ghost}, None }
| ";" { {value = []; region = Region.ghost}, Some $1 }
| ";" attributes ";" { $2, Some $1 }
const_decl:
open_const_decl ";"? {
{$1 with value = {$1.value with terminator=$2}} }
open_const_decl semi_attributes {
let attributes, terminator = $2 in
{$1 with value = {$1.value with terminator = terminator; attributes = attributes }}
}
instruction:
conditional { Cond $1 }
@ -529,9 +586,10 @@ if_clause:
clause_block:
block { LongBlock $1 }
| "{" sep_or_term_list(statement,";") "}" {
let statements, terminator = $2 in
let region = cover $1 $3 in
let value = {lbrace = $1;
inside = $2;
inside = attributes_to_statement statements, terminator;
rbrace = $3} in
ShortBlock {value; region} }

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

@ -114,6 +114,13 @@ let rec print_tokens state ast =
Utils.nseq_iter (print_decl state) decl;
print_token state eof "EOF"
and print_attributes state attributes =
let attributes = List.fold_left (fun all a -> all ^ a.value ^ ";") "" attributes.value in
let line =
sprintf "attributes[%s]"
attributes
in Buffer.add_string state#buffer line
and print_decl state = function
TypeDecl decl -> print_type_decl state decl
| ConstDecl decl -> print_const_decl state decl
@ -121,14 +128,15 @@ and print_decl state = function
and print_const_decl state {value; _} =
let {kwd_const; name; colon; const_type;
equal; init; terminator} = value in
equal; init; terminator; attributes} = value in
print_token state kwd_const "const";
print_var state name;
print_token state colon ":";
print_type_expr state const_type;
print_token state equal "=";
print_expr state init;
print_terminator state terminator
print_terminator state terminator;
print_attributes state attributes
and print_type_decl state {value; _} =
let {kwd_type; name; kwd_is;
@ -198,7 +206,7 @@ and print_type_tuple state {value; _} =
and print_fun_decl state {value; _} =
let {kwd_function; fun_name; param; colon;
ret_type; kwd_is; block_with;
return; terminator} = value in
return; terminator; attributes } = value in
print_token state kwd_function "function";
print_var state fun_name;
print_parameters state param;
@ -211,7 +219,8 @@ and print_fun_decl state {value; _} =
print_block state block;
print_token state kwd_with "with");
print_expr state return;
print_terminator state terminator
print_terminator state terminator;
print_attributes state attributes
and print_fun_expr state {value; _} =
let {kwd_function; param; colon;

1
src/passes/1-parser/pascaligo/SyntaxError.ml
View File

@ -6,6 +6,7 @@ type t =
| Duplicate_variant of AST.variable
| Non_linear_pattern of AST.variable
| Duplicate_field of AST.variable
| Detached_attributes of AST.attributes
type error = t

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

@ -4,6 +4,7 @@ type t =
| Duplicate_variant of AST.variable
| Non_linear_pattern of AST.variable
| Duplicate_field of AST.variable
| Detached_attributes of AST.attributes
type error = t

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

@ -87,6 +87,7 @@ type t =
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
(* Keywords *)
@ -135,12 +136,15 @@ type ident_err = Reserved_name
type nat_err = Invalid_natural
| Non_canonical_zero_nat
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
type kwd_err = Invalid_keyword
val mk_int : lexeme -> Region.t -> (token, int_err) result
val mk_nat : lexeme -> Region.t -> (token, nat_err) result
val mk_mutez : lexeme -> Region.t -> (token, int_err) result
val mk_ident : lexeme -> Region.t -> (token, ident_err) result
val mk_attr : lexeme -> Region.t -> (token, attr_err) result
val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result
val mk_sym : lexeme -> Region.t -> (token, sym_err) result
val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result
val mk_string : lexeme -> Region.t -> token

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

@ -71,6 +71,7 @@ type t =
| Mutez of (string * Z.t) Region.reg
| String of string Region.reg
| Bytes of (string * Hex.t) Region.reg
| Attr of string Region.reg
(* Keywords *)
@ -153,6 +154,7 @@ let proj_token = function
| Type region -> region, "Type"
| C_None region -> region, "C_None"
| C_Some region -> region, "C_Some"
| Attr Region.{region; value} -> region, sprintf "Attr %s" value
| EOF region -> region, "EOF"
let to_lexeme = function
@ -203,6 +205,7 @@ let to_lexeme = function
| Type _ -> "type"
| C_None _ -> "None"
| C_Some _ -> "Some"
| Attr a -> a.Region.value
| EOF _ -> ""
let to_string token ?(offsets=true) mode =
@ -219,6 +222,7 @@ type ident_err = Reserved_name
type nat_err = Invalid_natural
| Non_canonical_zero_nat
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
type kwd_err = Invalid_keyword
(* LEXIS *)
@ -447,6 +451,14 @@ let mk_constr' lexeme region lexicon =
let mk_constr lexeme region = mk_constr' lexeme region lexicon
(* Attributes *)
let mk_attr lexeme region =
Ok (Attr { value = lexeme; region })
let mk_attr2 _lexeme _region =
Error Invalid_attribute
(* Predicates *)
let is_string = function

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

@ -12,6 +12,7 @@
%token <(string * Z.t) Region.reg> Mutez "<mutez>"
%token <string Region.reg> Ident "<ident>"
%token <string Region.reg> Constr "<constr>"
%token <string Region.reg> Attr "<attr>"
(* Symbols *)

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

@ -226,12 +226,13 @@ field_decl:
(* Top-level non-recursive definitions *)
let_declaration:
"let" let_binding {
let kwd_let = $1 in
let binding = $2 in
let value = kwd_let, binding in
seq(Attr) "let" let_binding {
let attributes = $1 in
let kwd_let = $2 in
let binding = $3 in
let value = kwd_let, binding, attributes in
let stop = expr_to_region binding.let_rhs in
let region = cover $1 stop
let region = cover $2 stop
in {region; value} }
es6_func:
@ -408,6 +409,7 @@ type_expr_simple:
type_annotation_simple:
":" type_expr_simple { $1,$2 }
fun_expr:
disj_expr_level es6_func {
let arrow, body = $2 in
@ -464,7 +466,8 @@ fun_expr:
binders;
lhs_type=None;
arrow;
body}
body
}
in EFun {region; value=f} }
base_expr(right_expr):
@ -545,14 +548,15 @@ case_clause(right_expr):
in {region; value} }
let_expr(right_expr):
"let" let_binding ";" right_expr {
let kwd_let = $1 in
let binding = $2 in
let kwd_in = $3 in
let body = $4 in
let stop = expr_to_region $4 in
let region = cover $1 stop
and value = {kwd_let; binding; kwd_in; body}
seq(Attr) "let" 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 region = cover $2 stop
and value = {kwd_let; binding; kwd_in; body; attributes}
in ELetIn {region; value} }
disj_expr_level:

3
src/passes/1-parser/shared/Lexer.mli
View File

@ -65,6 +65,7 @@ module type TOKEN =
type nat_err = Invalid_natural
| Non_canonical_zero_nat
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
(* Injections *)
@ -76,6 +77,8 @@ module type TOKEN =
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token
val mk_attr : lexeme -> Region.t -> (token, attr_err) result
val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result
val eof : Region.t -> token
(* Predicates *)

30
src/passes/1-parser/shared/Lexer.mll
View File

@ -107,6 +107,7 @@ module type TOKEN =
type nat_err = Invalid_natural
| Non_canonical_zero_nat
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
(* Injections *)
@ -118,6 +119,8 @@ module type TOKEN =
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token
val mk_attr : lexeme -> Region.t -> (token, attr_err) result
val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result
val eof : Region.t -> token
(* Predicates *)
@ -384,6 +387,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
| Reserved_name of string
| Invalid_symbol
| Invalid_natural
| Invalid_attribute
let error_to_string = function
Invalid_utf8_sequence ->
@ -431,6 +435,8 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
Hint: Check the LIGO syntax you use.\n"
| Invalid_natural ->
"Invalid natural."
| Invalid_attribute ->
"Invalid attribute."
exception Error of error Region.reg
@ -524,6 +530,22 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
Ok token -> token, state
| Error Token.Reserved_name -> fail region (Reserved_name lexeme)
let mk_attr state buffer attr =
let region, _, state = sync state buffer in
match Token.mk_attr attr region with
Ok token ->
token, state
| Error Token.Invalid_attribute ->
fail region Invalid_attribute
let mk_attr2 state buffer attr =
let region, _, state = sync state buffer in
match Token.mk_attr2 attr region with
Ok token ->
token, state
| Error Token.Invalid_attribute ->
fail region Invalid_attribute
let mk_constr state buffer =
let region, lexeme, state = sync state buffer
in Token.mk_constr lexeme region, state
@ -537,6 +559,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
let mk_eof state buffer =
let region, _, state = sync state buffer
in Token.eof region, state
(* END HEADER *)
}
@ -563,8 +586,8 @@ let bytes = "0x" (byte_seq? as seq)
let esc = "\\n" | "\\\"" | "\\\\" | "\\b"
| "\\r" | "\\t" | "\\x" byte
let pascaligo_sym = "=/=" | '#' | ":="
let cameligo_sym = "<>" | "::" | "||" | "&&"
let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&"
let cameligo_sym = "<>" | "::" | "||" | "&&" | "[@"
let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&" | "[@"
let symbol =
';' | ',' | '(' | ')'| '[' | ']' | '{' | '}'
@ -603,7 +626,8 @@ and scan state = parse
| natural { mk_int state lexbuf |> enqueue }
| symbol { mk_sym state lexbuf |> enqueue }
| eof { mk_eof state lexbuf |> enqueue }
| "[@" (ident|constr as attr) "]" { mk_attr state lexbuf attr |> enqueue }
| "[@@" (ident|constr as attr) "]" { mk_attr2 state lexbuf attr |> enqueue }
| '"' { let opening, _, state = sync state lexbuf in
let thread = {opening; len=1; acc=['"']} in
scan_string thread state lexbuf |> mk_string |> enqueue }

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

@ -300,10 +300,10 @@ let rec simpl_expression :
trace (simplifying_expr t) @@
match t with
Raw.ELetIn e ->
let Raw.{binding; body; _} = e.value in
let Raw.{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
(* let p = rhs in body *)
| (p, []) ->
let%bind variables = tuple_pattern_to_typed_vars p in
let%bind ty_opt =
@ -338,18 +338,19 @@ let rec simpl_expression :
match variables with
| hd :: [] ->
if (List.length prep_vars = 1)
then e_let_in hd rhs_b_expr body
else e_let_in hd (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - 1)]) body
then e_let_in hd inline rhs_b_expr body
else e_let_in hd inline (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - 1)]) body
| hd :: tl ->
e_let_in hd
(e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)])
inline
(e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)])
(chain_let_in tl body)
| [] -> body (* Precluded by corner case assertion above *)
in
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) rhs' (chain_let_in prep_vars body))
else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body))
(* let f p1 ps... = rhs in body *)
| (f, p1 :: ps) ->
@ -486,7 +487,7 @@ let rec simpl_expression :
| Raw.PVar y ->
let var_name = Var.of_name y.value in
let%bind type_expr = simpl_type_expression x'.type_expr in
return @@ e_let_in (var_name , Some type_expr) e rhs
return @@ e_let_in (var_name , Some type_expr) false e rhs
| _ -> default_action ()
)
| _ -> default_action ()
@ -597,6 +598,7 @@ and simpl_fun lamb' : expr result =
binding= let_in_binding;
kwd_in= Region.ghost;
body= lamb.body;
attributes = []
}
in
ok (Raw.ELetIn
@ -701,8 +703,9 @@ 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 binding, _ = r_split x in
let binding = snd binding in
let (_, 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
@ -716,9 +719,9 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
match v_type with
| Some v_type -> ok (to_option (simpl_type_expression v_type))
| None -> ok None
in
in
let%bind simpl_rhs_expr = simpl_expression rhs_expr in
ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, simpl_rhs_expr) )
ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, simpl_rhs_expr) )
in let%bind variables = ok @@ npseq_to_list pt.value
in let%bind expr_bind_lst =
match let_rhs with
@ -757,14 +760,14 @@ 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 = fst @@ fst @@ r_split x in
let (wild, _, attributes) = fst @@ r_split x in
simpl_declaration
(Let {
region = x.region;
value = (wild, {binders = (pt, []);
lhs_type = lhs_type;
eq = Region.ghost ;
let_rhs = let_rhs})}
let_rhs = let_rhs}, attributes)}
: Raw.declaration)
| _ ->
let%bind (var, args) =
@ -778,17 +781,18 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
let%bind lhs_type' =
bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in
let%bind rhs' = simpl_expression let_rhs in
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type' , rhs'))]
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type' , inline, rhs'))]
| param1::others ->
let fun_ = {
kwd_fun = Region.ghost;
binders = param1, others;
lhs_type;
arrow = Region.ghost;
body = let_rhs} in
body = let_rhs
} in
let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in
let%bind rhs' = simpl_expression rhs in
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , None , rhs'))]
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , None , inline, rhs'))]
)
and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result =

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

@ -194,10 +194,10 @@ let r_split = Location.r_split
[return_statement] is used for non-let-in statements.
*)
let return_let_in ?loc binder rhs = ok @@ fun expr'_opt ->
let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt ->
match expr'_opt with
| None -> fail @@ corner_case ~loc:__LOC__ "missing return"
| Some expr' -> ok @@ e_let_in ?loc binder rhs expr'
| Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr'
let return_statement expr = ok @@ fun expr'_opt ->
match expr'_opt with
@ -572,17 +572,19 @@ and simpl_data_declaration : Raw.data_decl -> _ result = fun t ->
let name = x.name.value in
let%bind t = simpl_type_expression x.var_type in
let%bind expression = simpl_expression x.init in
return_let_in ~loc (Var.of_name name , Some t) expression
return_let_in ~loc (Var.of_name name , Some t) false expression
| LocalConst x ->
let (x , loc) = r_split x in
let name = x.name.value in
let%bind t = simpl_type_expression x.const_type in
let%bind expression = simpl_expression x.init in
return_let_in ~loc (Var.of_name name , Some t) expression
let inline = List.exists (fun (f: Raw.attribute) -> f.value = "\"inline\"") x.attributes.value in
return_let_in ~loc (Var.of_name name , Some t) inline expression
| LocalFun f ->
let (f , loc) = r_split f in
let%bind (binder, expr) = simpl_fun_decl ~loc f
in return_let_in ~loc binder expr
let%bind (binder, expr) = simpl_fun_decl ~loc f in
let inline = List.exists (fun (f: Raw.attribute) -> f.value = "\"inline\"") f.attributes.value in
return_let_in ~loc binder inline expr
and simpl_param : Raw.param_decl -> (expression_variable * type_expression) result =
fun t ->
@ -602,7 +604,8 @@ and simpl_fun_decl :
loc:_ -> Raw.fun_decl -> ((expression_variable * type_expression option) * expression) result =
fun ~loc x ->
let open! Raw in
let {fun_name;param;ret_type;block_with;return} : fun_decl = x in
let {fun_name;param;ret_type;block_with;return; attributes} : fun_decl = x in
let inline = List.exists (fun (a: Raw.attribute) -> a.value = "\"inline\"") attributes.value in
let statements =
match block_with with
| Some (block,_) -> npseq_to_list block.value.statements
@ -640,7 +643,7 @@ and simpl_fun_decl :
let expr =
e_accessor (e_variable arguments_name) [Access_tuple i] in
let type_variable = Some (snd x) in
let ass = return_let_in (fst x , type_variable) expr in
let ass = return_let_in (fst x , type_variable) inline expr in
ass
in
bind_list @@ List.mapi aux params in
@ -698,7 +701,7 @@ and simpl_fun_expression :
let expr =
e_accessor (e_variable arguments_name) [Access_tuple i] in
let type_variable = Some (snd x) in
let ass = return_let_in (fst x , type_variable) expr in
let ass = return_let_in (fst x , type_variable) false expr in
ass
in
bind_list @@ List.mapi aux params in
@ -730,17 +733,19 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result =
(Var.of_name name.value, type_expression))
| ConstDecl x ->
let simpl_const_decl = fun {name;const_type;init} ->
let simpl_const_decl = fun {name;const_type; init; attributes} ->
let%bind expression = simpl_expression init in
let%bind t = simpl_type_expression const_type in
let type_annotation = Some t in
let inline = List.exists (fun (a: Raw.attribute) -> a.value = "\"inline\"") attributes.value in
ok @@ Declaration_constant
(Var.of_name name.value, type_annotation, expression)
(Var.of_name name.value, type_annotation, inline, expression)
in bind_map_location simpl_const_decl (Location.lift_region x)
| FunDecl x ->
let decl, loc = r_split x in
let%bind ((name, ty_opt), expr) = simpl_fun_decl ~loc decl in
ok @@ Location.wrap ~loc (Declaration_constant (name, ty_opt, expr))
let inline = List.exists (fun (a: Raw.attribute) -> a.value = "\"inline\"") x.value.attributes.value in
ok @@ Location.wrap ~loc (Declaration_constant (name, ty_opt, inline, expr))
and simpl_statement : Raw.statement -> (_ -> expression result) result =
fun s ->
@ -1102,7 +1107,7 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
| _ -> e_sequence body ctrl in
let body' = add_to_seq body in
let loop = e_loop comp body' in
return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) value loop
return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) false value loop
(** simpl_for_collect
For loops over collections, like
@ -1268,14 +1273,14 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
let acc = arg_access [Access_tuple 0 ] in
let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in
let collec_elt_k = arg_access [Access_tuple 1 ; Access_tuple 1] in
e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *)
e_let_in (Var.of_name elt_name, None) collec_elt_v @@
e_let_in (Var.of_name elt_v_name, None) collec_elt_k (for_body)
e_let_in (Var.of_name "#COMPILER#acc", None) false acc @@ (* TODO fresh *)
e_let_in (Var.of_name elt_name, None) false collec_elt_v @@
e_let_in (Var.of_name elt_v_name, None) false collec_elt_k (for_body)
| _ ->
let acc = arg_access [Access_tuple 0] in
let collec_elt = arg_access [Access_tuple 1] in
e_let_in (Var.of_name "#COMPILER#acc", None) acc @@ (* TODO fresh *)
e_let_in (Var.of_name elt_name, None) collec_elt (for_body)
e_let_in (Var.of_name "#COMPILER#acc", None) false acc @@ (* TODO fresh *)
e_let_in (Var.of_name elt_name, None) false collec_elt (for_body)
) in
(* STEP 7 *)
let%bind collect = simpl_expression fc.expr in
@ -1296,7 +1301,7 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
let final_sequence = match reassign_sequence with
(* None case means that no variables were captured *)
| None -> e_skip ()
| Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) fold seq in (* TODO fresh *)
| Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) false fold seq in (* TODO fresh *)
return_statement @@ final_sequence
let simpl_program : Raw.ast -> program result = fun t ->

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

@ -157,10 +157,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind ab' = bind_map_pair self ab in
return @@ E_application ab'
)
| E_let_in { binder ; rhs ; result } -> (
| E_let_in { binder ; rhs ; result; inline } -> (
let%bind rhs = self rhs in
let%bind result = self result in
return @@ E_let_in { binder ; rhs ; result }
return @@ E_let_in { binder ; rhs ; result; inline }
)
| E_lambda { binder ; input_type ; output_type ; result } -> (
let%bind result = self result in
@ -206,9 +206,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 (t , o , e) -> (
| Declaration_constant (t , o , i, e) -> (
let%bind e' = map_expression m e in
ok (Declaration_constant (t , o , e'))
ok (Declaration_constant (t , o , i, e'))
)
| Declaration_type _ -> ok x
in

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

@ -218,7 +218,7 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type type_name tv env in
ok (env', state , None)
| Declaration_constant (name , tv_opt , expression) -> (
| Declaration_constant (name , tv_opt , inline, expression) -> (
(*
Determine the type of the expression and add it to the environment
*)
@ -227,7 +227,7 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat
trace (constant_declaration_error name expression tv'_opt) @@
type_expression env state expression in
let env' = Environment.add_ez_ae name ae' env in
ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , (env , env'))))
ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , inline, (env , env'))))
)
and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.matching -> I.expression -> Location.t -> ((O.value, O.type_value) O.matching * Solver.state) result =
@ -781,7 +781,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind (body' , state'') = type_expression e state' body in
let wrapped = Wrap.loop expr'.type_annotation body'.type_annotation in
return_wrapped (O.E_loop (expr' , body')) state'' wrapped
| E_let_in {binder ; rhs ; result} ->
| E_let_in {binder ; rhs ; result ; inline} ->
let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in
(* TODO: the binder annotation should just be an annotation node *)
let%bind (rhs , state') = type_expression e state rhs in
@ -789,7 +789,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind (result , state'') = type_expression e' state' result in
let wrapped =
Wrap.let_in rhs.type_annotation rhs_tv_opt result.type_annotation in
return_wrapped (E_let_in {binder = fst binder; rhs; result}) state'' wrapped
return_wrapped (E_let_in {binder = fst binder; rhs; result; inline}) state'' wrapped
| E_assign (name , path , expr) ->
let%bind typed_name =
let%bind ele = Environment.get_trace name e in
@ -1143,11 +1143,11 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_sequence _
| E_loop _
| E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression
| E_let_in {binder; rhs;result} ->
| E_let_in {binder; rhs; result; inline} ->
let%bind tv = untype_type_value rhs.type_annotation in
let%bind rhs = untype_expression rhs in
let%bind result = untype_expression result in
return (e_let_in (binder , (Some tv)) rhs result)
return (e_let_in (binder , (Some tv)) inline rhs result)
(*
Tranform a Ast_typed matching into an ast_simplified matching

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

@ -218,13 +218,13 @@ and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) :
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type type_name tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
| Declaration_constant (name , tv_opt , expression) -> (
| Declaration_constant (name , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind ae' =
trace (constant_declaration_error name expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in
let env' = Environment.add_ez_ae name ae' env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant ((make_n_e name ae') , (env , env'))))
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant ((make_n_e name ae') , inline, (env , env'))))
)
and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> (i, unit) I.matching -> I.expression -> Location.t -> (o, O.type_value) O.matching result =
@ -805,12 +805,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
expr'.location) @@
Ast_typed.assert_type_value_eq (assign_tv , t_expr') in
return (O.E_assign (typed_name , path' , expr')) (t_unit ())
| E_let_in {binder ; rhs ; result} ->
| E_let_in {binder ; rhs ; result; inline} ->
let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in
let%bind rhs = type_expression' ?tv_opt:rhs_tv_opt e rhs in
let e' = Environment.add_ez_declaration (fst binder) rhs e in
let%bind result = type_expression' e' result in
return (E_let_in {binder = fst binder; rhs; result}) result.type_annotation
return (E_let_in {binder = fst binder; rhs; result; inline}) result.type_annotation
| E_ascription (expr , te) ->
let%bind tv = evaluate_type e te in
let%bind expr' = type_expression' ~tv_opt:tv e expr in
@ -926,11 +926,11 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_sequence _
| E_loop _
| E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression
| E_let_in {binder;rhs;result} ->
| E_let_in {binder; rhs; result; inline} ->
let%bind tv = untype_type_value rhs.type_annotation in
let%bind rhs = untype_expression rhs in
let%bind result = untype_expression result in
return (e_let_in (binder , (Some tv)) rhs result)
return (e_let_in (binder , (Some tv)) inline rhs result)
and untype_matching : type o i . (o -> i result) -> (o,O.type_value) O.matching -> ((i,unit) I.matching) result = fun f m ->
let open I in

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

@ -258,10 +258,10 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
info title content in
trace info @@
match ae.expression with
| E_let_in {binder; rhs; result} ->
| E_let_in {binder; rhs; result; inline} ->
let%bind rhs' = transpile_annotated_expression rhs in
let%bind result' = transpile_annotated_expression result in
return (E_let_in ((binder, rhs'.type_value), rhs', result'))
return (E_let_in ((binder, rhs'.type_value), inline, rhs', result'))
| E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> (
let%bind ele =
@ -587,7 +587,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let%bind body' = transpile_annotated_expression body in
return @@ E_let_in ((name , tv) , top , body')
return @@ E_let_in ((name , tv) , false , top , body')
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
@ -621,11 +621,11 @@ and transpile_lambda l (input_type , output_type) =
let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
match d with
| Declaration_constant ({name;annotated_expression} , _) ->
| Declaration_constant ({name;annotated_expression} , inline , _) ->
let%bind expression = transpile_annotated_expression annotated_expression in
let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (name, tv) env in
ok @@ ((name, expression), environment_wrap env env')
ok @@ ((name, inline, expression), environment_wrap env env')
let transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur =

6
src/passes/7-self_mini_c/helpers.ml
View File

@ -72,7 +72,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_triple self init' (c,l,r) in
ok res
)
| E_let_in ((_, _) , expr , body) -> (
| E_let_in ((_, _) , _inline, expr , body) -> (
let%bind res = bind_fold_pair self init' (expr,body) in
ok res
)
@ -146,9 +146,9 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind (c',l',r') = bind_map_triple self (c,l,r) in
return @@ E_if_left (c', ((name_l, tvl) , l'), ((name_r, tvr) , r'))
)
| E_let_in ((v , tv) , expr , body) -> (
| E_let_in ((v , tv) , inline, expr , body) -> (
let%bind (expr',body') = bind_map_pair self (expr,body) in
return @@ E_let_in ((v , tv) , expr' , body')
return @@ E_let_in ((v , tv) , inline , expr' , body')
)
| E_sequence ab -> (
let%bind ab' = bind_map_pair self ab in

10
src/passes/7-self_mini_c/self_mini_c.ml
View File

@ -60,7 +60,7 @@ let rec is_pure : expression -> bool = fun e ->
| E_if_left (cond, (_, bt), (_, bf))
-> List.for_all is_pure [ cond ; bt ; bf ]
| E_let_in (_, e1, e2)
| E_let_in (_, _, e1, e2)
| E_sequence (e1, e2)
-> List.for_all is_pure [ e1 ; e2 ]
@ -133,7 +133,7 @@ let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression -
selfs [ e1 ; e2 ] || self_binder2 hd tl e3
| E_if_left (e1, ((l, _), e2), ((r, _), e3)) ->
self e1 || self_binder l e2 || self_binder r e3
| E_let_in ((x, _), e1, e2) ->
| E_let_in ((x, _), _, e1, e2) ->
self e1 || self_binder x e2
| E_sequence (e1, e2) ->
selfs [ e1 ; e2 ]
@ -188,8 +188,8 @@ let should_inline : expression_variable -> expression -> bool =
let inline_let : bool ref -> expression -> expression =
fun changed e ->
match e.content with
| E_let_in ((x, _a), e1, e2) ->
if can_inline x e1 e2 && should_inline x e2
| E_let_in ((x, _a), should_inline_here, e1, e2) ->
if can_inline x e1 e2 && (should_inline_here || should_inline x e2)
then
(* can raise Subst.Bad_argument, but should not happen, due to
can_inline *)
@ -232,7 +232,7 @@ let beta : bool ref -> expression -> expression =
if can_beta { binder = x ; body = e1 }
then
(changed := true ;
Expression.make (E_let_in ((x, xtv), e2, e1)) tv)
Expression.make (E_let_in ((x, xtv), false, e2, e1)) tv)
else e
(* also do CAR (PAIR x y) ↦ x, or CDR (PAIR x y) ↦ y, only if x and y are pure *)

14
src/passes/7-self_mini_c/subst.ml
View File

@ -81,11 +81,11 @@ let rec replace : expression -> var_name -> var_name -> expression =
let v2 = replace_var v2 in
let bt = replace bt in
return @@ E_if_left (c, ((v1, tv1), bt), ((v2, tv2), bf))
| E_let_in ((v, tv), e1, e2) ->
| E_let_in ((v, tv), inline, e1, e2) ->
let v = replace_var v in
let e1 = replace e1 in
let e2 = replace e2 in
return @@ E_let_in ((v, tv), e1, e2)
return @@ E_let_in ((v, tv), inline, e1, e2)
| E_sequence (e1, e2) ->
let e1 = replace e1 in
let e2 = replace e2 in
@ -144,10 +144,10 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
let (binder, body) = subst_binder binder body in
return @@ E_closure { binder ; body }
)
| E_let_in ((v , tv) , expr , body) -> (
| E_let_in ((v , tv) , inline, expr , body) -> (
let expr = self expr in
let (v, body) = subst_binder v body in
return @@ E_let_in ((v , tv) , expr , body)
return @@ E_let_in ((v , tv) , inline, expr , body)
)
| E_iterator (s, ((name , tv) , body) , collection) -> (
let (name, body) = subst_binder name body in
@ -292,7 +292,7 @@ let%expect_test _ =
(* let-in shadowed (not in rhs) *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_let_in ((x, dummy_type), var x, var x)))
~body:(wrap (E_let_in ((x, dummy_type), false, var x, var x)))
~x:x
~expr:unit ;
[%expect{|
@ -303,7 +303,7 @@ let%expect_test _ =
(* let-in not shadowed *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_let_in ((y, dummy_type), var x, var x)))
~body:(wrap (E_let_in ((y, dummy_type), false, var x, var x)))
~x:x
~expr:unit ;
[%expect{|
@ -314,7 +314,7 @@ let%expect_test _ =
(* let-in capture avoidance *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_let_in ((y, dummy_type), var x,
~body:(wrap (E_let_in ((y, dummy_type), false, var x,
app (var x) (var y))))
~x:x
~expr:(var y) ;

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

@ -316,7 +316,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
]) in
return code
)
| E_let_in (v , expr , body) -> (
| E_let_in (v , _, expr , body) -> (
let%bind expr' = translate_expression expr env in
let%bind body' = translate_expression body (Environment.add v env) in
let%bind code = ok (seq [

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

@ -52,8 +52,8 @@ let rec expression ppf (e:expression) = match e.expression with
name n
PP_helpers.(list_sep access (const ".")) path
expression expr
| E_let_in { binder ; rhs ; result } ->
fprintf ppf "let %a = %a in %a" option_type_name binder expression rhs expression result
| E_let_in { binder ; rhs ; result; inline } ->
fprintf ppf "let %a = %a%a in %a" option_type_name binder expression rhs option_inline inline expression result
| E_skip -> fprintf ppf "skip"
| E_ascription (expr , ty) -> fprintf ppf "%a : %a" expression expr type_expression ty
@ -62,6 +62,12 @@ and option_type_name ppf ((n , ty_opt) : expression_variable * type_expression o
| None -> fprintf ppf "%a" name n
| Some ty -> fprintf ppf "%a : %a" name n type_expression ty
and option_inline ppf inline =
if inline then
fprintf ppf "[@inline]"
else
fprintf ppf ""
and assoc_expression ppf : (expr * expr) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" expression a expression b
@ -119,8 +125,8 @@ and matching_variant_case_type ppf ((c,n),_a) =
let declaration ppf (d:declaration) = match d with
| Declaration_type (type_name , te) ->
fprintf ppf "type %a = %a" type_variable (type_name) type_expression te
| Declaration_constant (name , ty_opt , expr) ->
fprintf ppf "const %a = %a" option_type_name (name , ty_opt) expression expr
| Declaration_constant (name , ty_opt , inline, expr) ->
fprintf ppf "const %a = %a%a" option_type_name (name , ty_opt) expression expr option_inline inline
let program ppf (p:program) =
fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)

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

@ -117,7 +117,7 @@ let e_variable ?loc v = location_wrap ?loc @@ E_variable v
let e_skip ?loc () = location_wrap ?loc @@ E_skip
let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body)
let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b)
let e_let_in ?loc (binder, ascr) rhs result = location_wrap ?loc @@ E_let_in { binder = (binder, ascr) ; rhs ; result }
let e_let_in ?loc (binder, ascr) inline rhs result = location_wrap ?loc @@ E_let_in { binder = (binder, ascr) ; rhs ; result ; inline }
let e_annotation ?loc expr ty = location_wrap ?loc @@ E_ascription (expr , ty)
let e_application ?loc a b = location_wrap ?loc @@ E_application (a , b)
let e_binop ?loc name a b = location_wrap ?loc @@ E_constant (name , [a ; b])

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

@ -84,7 +84,7 @@ val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_skip : ?loc:Location.t -> unit -> expression
val e_loop : ?loc:Location.t -> expression -> expression -> expression
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> inline -> expression -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_binop : ?loc:Location.t -> constant -> expression -> expression -> expression

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

@ -4,12 +4,14 @@ include Stage_common.Types
type program = declaration Location.wrap list
and inline = bool
and type_expression = {
type_expression' : type_expression type_expression'
}
and declaration =
| Declaration_type of (type_variable * type_expression)
| Declaration_constant of (expression_variable * type_expression option * expression)
| Declaration_constant of (expression_variable * type_expression option * inline * expression)
(* | Macro_declaration of macro_declaration *)
and expr = expression
@ -22,9 +24,10 @@ and lambda = {
}
and let_in = {
binder : (expression_variable * type_expression option) ;
rhs : expr ;
result : expr ;
binder : (expression_variable * type_expression option) ;
rhs : expr ;
result : expr ;
inline : inline;
}
and expression' =

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

@ -24,6 +24,12 @@ and lambda ppf l =
name binder
annotated_expression body
and option_inline ppf inline =
if inline then
fprintf ppf "[@inline]"
else
fprintf ppf ""
and expression ppf (e:expression) : unit =
match e with
| E_literal l -> Stage_common.PP.literal ppf l
@ -51,7 +57,8 @@ and expression ppf (e:expression) : unit =
Stage_common.PP.name name.type_name
PP_helpers.(list_sep pre_access (const ".")) path
annotated_expression expr
| E_let_in { binder; rhs; result } -> fprintf ppf "let %a = %a in %a" name binder annotated_expression rhs annotated_expression result
| E_let_in { binder; rhs; result; inline } ->
fprintf ppf "let %a = %a%a in %a" name binder annotated_expression rhs option_inline inline annotated_expression result
and value ppf v = annotated_expression ppf v
@ -83,8 +90,8 @@ and pre_access ppf (a:access) = match a with
let declaration ppf (d:declaration) =
match d with
| Declaration_constant ({name ; annotated_expression = ae} , _) ->
fprintf ppf "const %a = %a" Stage_common.PP.name name annotated_expression ae
| Declaration_constant ({name ; annotated_expression = ae} , inline, _) ->
fprintf ppf "const %a = %a%a" Stage_common.PP.name name annotated_expression ae option_inline inline
let program ppf (p:program) =
fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)

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

@ -276,7 +276,7 @@ let e_pair a b : expression = E_tuple [a; b]
let e_application a b : expression = E_application (a , b)
let e_variable v : expression = E_variable v
let e_list lst : expression = E_list lst
let e_let_in binder rhs result = E_let_in { binder ; rhs ; result }
let e_let_in binder inline rhs result = E_let_in { binder ; rhs ; result; inline }
let e_tuple lst : expression = E_tuple lst
let e_a_unit = make_a_e e_unit (t_unit ())
@ -297,7 +297,7 @@ let e_a_variable v ty = make_a_e (e_variable v) ty
let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ())
let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ())
let e_a_list lst t = make_a_e (e_list lst) (t_list t ())
let e_a_let_in binder expr body = make_a_e (e_let_in binder expr body) (get_type_annotation body)
let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_annotation body)
let get_a_int (t:annotated_expression) =
match t.expression with
@ -323,7 +323,7 @@ let get_a_record_accessor = fun t ->
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration ->
match declaration with
| Declaration_constant (d , _) -> d.name = Var.of_name name
| Declaration_constant (d , _, _) -> d.name = Var.of_name name
in
trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p

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

@ -132,7 +132,7 @@ val e_pair : value -> value -> expression
val e_application : value -> value -> expression
val e_variable : expression_variable -> expression
val e_list : value list -> expression
val e_let_in : expression_variable -> value -> value -> expression
val e_let_in : expression_variable -> inline -> value -> value -> expression
val e_tuple : value list -> expression
val e_a_unit : full_environment -> annotated_expression
@ -153,7 +153,7 @@ val e_a_variable : expression_variable -> type_value -> full_environment -> anno
val ez_e_a_record : ( label * annotated_expression ) list -> full_environment -> annotated_expression
val e_a_map : ( annotated_expression * annotated_expression ) list -> type_value -> type_value -> full_environment -> annotated_expression
val e_a_list : annotated_expression list -> type_value -> full_environment -> annotated_expression
val e_a_let_in : expression_variable -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val e_a_let_in : expression_variable -> inline -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val get_a_int : annotated_expression -> int result
val get_a_unit : annotated_expression -> unit result

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

@ -188,7 +188,7 @@ module Free_variables = struct
| E_sequence (a , b) -> unions @@ List.map self [ a ; b ]
| E_loop (expr , body) -> unions @@ List.map self [ expr ; body ]
| E_assign (_ , _ , expr) -> self expr
| E_let_in { binder; rhs; result } ->
| E_let_in { binder; rhs; result; _ } ->
let b' = union (singleton binder) b in
union
(annotated_expression b' result)
@ -529,7 +529,7 @@ let merge_annotation (a:type_value option) (b:type_value option) err : type_valu
let get_entry (lst : program) (name : string) : annotated_expression result =
trace_option (Errors.missing_entry_point name) @@
let aux x =
let (Declaration_constant (an , _)) = Location.unwrap x in
let (Declaration_constant (an , _, _)) = Location.unwrap x in
if (an.name = Var.of_name name)
then Some an.annotated_expression
else None
@ -539,4 +539,4 @@ let get_entry (lst : program) (name : string) : annotated_expression result =
let program_environment (program : program) : full_environment =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , (_ , post_env)) -> post_env
| Declaration_constant (_ , _, (_ , post_env)) -> post_env

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

@ -8,7 +8,7 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) =
let pred = fun d ->
match d with
| Declaration_constant (d , _) when d.name = Var.of_name s -> Some d.annotated_expression
| Declaration_constant (d , _, _) when d.name = Var.of_name s -> Some d.annotated_expression
| Declaration_constant _ -> None
in
let%bind main =
@ -23,7 +23,7 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let env =
let aux = fun _ d ->
match d with
| Declaration_constant (_ , (_ , post_env)) -> post_env in
| Declaration_constant (_ , _, (_ , post_env)) -> post_env in
List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
let binder = Var.of_name "@contract_input" in
let body =

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

@ -5,8 +5,10 @@ include Stage_common.Types
type program = declaration Location.wrap list
and inline = bool
and declaration =
| Declaration_constant of (named_expression * (full_environment * full_environment))
| Declaration_constant of (named_expression * inline * (full_environment * full_environment))
(* | Macro_declaration of macro_declaration *)
and environment_element_definition =
@ -64,6 +66,7 @@ and let_in = {
binder: expression_variable;
rhs: ae;
result: ae;
inline: inline;
}
and 'a expression' =

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

@ -91,8 +91,8 @@ and expression' ppf (e:expression') = match e with
| E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Stage_common.PP.name name_l expression l Stage_common.PP.name name_r expression r
| E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b
| E_let_in ((name , _) , expr , body) ->
fprintf ppf "let %a = %a in ( %a )" Stage_common.PP.name name expression expr expression body
| E_let_in ((name , _) , inline, expr , body) ->
fprintf ppf "let %a = %a%a in ( %a )" Stage_common.PP.name name expression expr option_inline inline expression body
| E_iterator (b , ((name , _) , body) , expr) ->
fprintf ppf "for_%a %a of %a do ( %a )" Stage_common.PP.constant b Stage_common.PP.name name expression expr expression body
| E_fold (((name , _) , body) , collection , initial) ->
@ -117,9 +117,17 @@ and function_ ppf ({binder ; body}:anon_function) =
Stage_common.PP.name binder
expression body
and assignment ppf ((n, e):assignment) = fprintf ppf "%a = %a;" Stage_common.PP.name n expression e
and assignment ppf ((n, i, e):assignment) =
fprintf ppf "%a = %a%a;" Stage_common.PP.name n expression e option_inline i
and declaration ppf ((n, e):assignment) = fprintf ppf "let %a = %a;" Stage_common.PP.name n expression e
and option_inline ppf inline =
if inline then
fprintf ppf "[@inline]"
else
fprintf ppf ""
and declaration ppf ((n, i, e):assignment) =
fprintf ppf "let %a = %a%a;" Stage_common.PP.name n expression e option_inline i
let tl_statement ppf (ass, _) = assignment ppf ass

4
src/stages/mini_c/combinators.ml
View File

@ -172,8 +172,8 @@ let e_int expr : expression = Expression.make_tpl (expr, t_int)
let e_unit : expression = Expression.make_tpl (E_literal D_unit, t_unit)
let e_skip : expression = Expression.make_tpl (E_skip, t_unit)
let e_var_int name : expression = e_int (E_variable name)
let e_let_in v tv expr body : expression = Expression.(make_tpl (
E_let_in ((v , tv) , expr , body) ,
let e_let_in v tv inline expr body : expression = Expression.(make_tpl (
E_let_in ((v , tv) , inline, expr , body) ,
get_type body
))

2
src/stages/mini_c/combinators.mli
View File

@ -67,7 +67,7 @@ val e_int : Expression.t' -> Expression.t
val e_unit : Expression.t
val e_skip : Expression.t
val e_var_int : expression_variable -> Expression.t
val e_let_in : expression_variable -> type_value -> Expression.t -> Expression.t -> Expression.t
val e_let_in : expression_variable -> type_value -> inline -> Expression.t -> Expression.t -> Expression.t
val ez_e_sequence : Expression.t' -> Expression.t -> expression
(*

10
src/stages/mini_c/misc.ml
View File

@ -74,7 +74,7 @@ module Free_variables = struct
expression (union (singleton l) b) bl ;
expression (union (singleton r) b) br ;
]
| E_let_in ((v , _) , expr , body) ->
| E_let_in ((v , _) , _, expr , body) ->
unions [ self expr ;
expression (union (singleton v) b) body ;
]
@ -125,7 +125,7 @@ let get_entry (lst : program) (name : string) : (expression * int) result =
let%bind entry_expression =
trace_option (Errors.missing_entry_point name) @@
let aux x =
let (((decl_name , decl_expr) , _)) = x in
let (((decl_name , _, decl_expr) , _)) = x in
if (Var.equal decl_name (Var.of_name name))
then Some decl_expr
else None
@ -134,7 +134,7 @@ let get_entry (lst : program) (name : string) : (expression * int) result =
in
let entry_index =
let aux x =
let (((decl_name , _) , _)) = x in
let (((decl_name , _, _) , _)) = x in
Var.equal decl_name (Var.of_name name)
in
(List.length lst) - (List.find_index aux (List.rev lst)) - 1
@ -148,8 +148,8 @@ type form_t =
let aggregate_entry (lst : program) (form : form_t) : expression result =
let wrapper =
let aux prec cur =
let (((name , expr) , _)) = cur in
e_let_in name expr.type_value expr prec
let (((name , inline, expr) , _)) = cur in
e_let_in name expr.type_value inline expr prec
in
fun expr -> List.fold_right' aux expr lst
in

6
src/stages/mini_c/types.ml
View File

@ -27,6 +27,8 @@ type environment_wrap = {
type var_name = expression_variable
type fun_name = expression_variable
type inline = bool
type value =
| D_unit
| D_bool of bool
@ -68,7 +70,7 @@ and expression' =
| E_if_none of expression * expression * ((var_name * type_value) * expression)
| E_if_cons of (expression * expression * (((var_name * type_value) * (var_name * type_value)) * expression))
| E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression)
| E_let_in of ((var_name * type_value) * expression * expression)
| E_let_in of ((var_name * type_value) * inline * expression * expression)
| E_sequence of (expression * expression)
| E_assignment of (expression_variable * [`Left | `Right] list * expression)
| E_update of (expression * ([`Left | `Right] list * expression) list)
@ -79,7 +81,7 @@ and expression = {
type_value : type_value ;
}
and assignment = var_name * expression
and assignment = var_name * inline * expression
and toplevel_statement = assignment * environment_wrap

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

@ -147,11 +147,11 @@ module Substitution = struct
let%bind binder = s_variable ~v ~expr binder in
let%bind body = s_annotated_expression ~v ~expr body in
ok @@ T.E_lambda { binder; body }
| T.E_let_in { binder; rhs; result } ->
| T.E_let_in { binder; rhs; result; inline } ->
let%bind binder = s_variable ~v ~expr binder in
let%bind rhs = s_annotated_expression ~v ~expr rhs in
let%bind result = s_annotated_expression ~v ~expr result in
ok @@ T.E_let_in { binder; rhs; result }
ok @@ T.E_let_in { binder; rhs; result; inline }
| T.E_tuple vals ->
let%bind vals = bind_map_list (s_annotated_expression ~v ~expr) vals in
ok @@ T.E_tuple vals
@ -235,11 +235,11 @@ module Substitution = struct
and s_declaration ~v ~expr : T.declaration w =
function
Ast_typed.Declaration_constant (e, (env1, env2)) ->
Ast_typed.Declaration_constant (e, i, (env1, env2)) ->
let%bind e = s_named_expression ~v ~expr e in
let%bind env1 = s_full_environment ~v ~expr env1 in
let%bind env2 = s_full_environment ~v ~expr env2 in
ok @@ Ast_typed.Declaration_constant (e, (env1, env2))
ok @@ Ast_typed.Declaration_constant (e, i, (env1, env2))
and s_declaration_wrap ~v ~expr : T.declaration Location.wrap w = fun d ->
Trace.bind_map_location (s_declaration ~v ~expr) d

17
src/test/contracts/attributes.ligo Normal file
View File

@ -0,0 +1,17 @@
const x: int = 1; attributes ["inline"];
function foo (const a : int) : int is
block {
const test: int = 2 + a; attributes ["inline"];
} with test;
attributes ["inline"];
const y: int = 1; attributes ["inline"; "other"];
function bar (const b : int) : int is
block {
function test (const z : int) : int is begin
const r : int = 2 + b + z
end with r;
attributes ["inline"; "foo"; "bar"];
} with test(b);

13
src/test/contracts/attributes.mligo Normal file
View File

@ -0,0 +1,13 @@
let x = 1 [@@inline]
let foo (a: int): int = (
let test = 2 + a [@@inline] in
test
) [@@inline]
let y = 1 [@@inline][@@other]
let bar (b: int): int = (
let test = fun (z: int) -> 2 + b + z [@@inline][@@foo][@@bar] in
test b
)

18
src/test/contracts/attributes.religo Normal file
View File

@ -0,0 +1,18 @@
[@inline]
let x = 1;
[@inline]
let foo = (a: int): int => {
[@inline]
let test = 2 + a;
test;
};
[@inline][@other]
let y = 1;
let bar = (b: int): int => {
[@inline][@foo][@bar]
let test = (z: int) => 2 + b + z;
test(b);
};

30
src/test/integration_tests.ml
View File

@ -1846,6 +1846,33 @@ let deep_access_ligo () : unit result =
let make_expected = e_string "one" in
expect_eq program "nested_record" make_input make_expected in
ok ()
let attributes_ligo () : unit result =
let%bind program = type_file "./contracts/attributes.ligo" in
let%bind () =
let input = e_int 3 in
let expected = e_int 5 in
expect_eq program "foo" input expected
in
ok ()
let attributes_mligo () : unit result =
let%bind program = mtype_file "./contracts/attributes.mligo" in
let%bind () =
let input = e_int 3 in
let expected = e_int 5 in
expect_eq program "foo" input expected
in
ok ()
let attributes_religo () : unit result =
let%bind program = retype_file "./contracts/attributes.religo" in
let%bind () =
let input = e_int 3 in
let expected = e_int 5 in
expect_eq program "foo" input expected
in
ok ()
let entrypoints_ligo () : unit result =
@ -2127,6 +2154,9 @@ let main = test_suite "Integration (End to End)" [
test "entrypoints (ligo)" entrypoints_ligo ;
test "curry (mligo)" curry ;
test "type tuple destruct (mligo)" type_tuple_destruct ;
test "attributes (ligo)" attributes_ligo;
test "attributes (mligo)" attributes_mligo;
test "attributes (religo)" attributes_religo;
test "let in multi-bind (mligo)" let_in_multi_bind ;
test "tuple param destruct (mligo)" tuple_param_destruct ;
test "empty case" empty_case ;

2
src/test/md_file_tests.ml
View File

@ -72,7 +72,7 @@ let compile_groups _filename grp_list =
let%bind typed,_ = Compile.Of_simplified.compile simplified in
let%bind mini_c = Compile.Of_typed.compile typed in
bind_map_list
(fun ((_,exp),_) -> Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp)
(fun ((_, _, exp),_) -> Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp)
mini_c
)
grp_list in

2
src/test/multisig_v2_tests.ml
View File

@ -35,7 +35,7 @@ let empty_message = e_lambda (Var.of_name "arguments")
empty_op_list
let empty_message2 = e_lambda (Var.of_name "arguments")
(Some t_bytes) (Some (t_list t_operation))
( e_let_in ((Var.of_name "foo"),Some t_unit) (e_unit ()) empty_op_list)
( e_let_in ((Var.of_name "foo"),Some t_unit) false (e_unit ()) empty_op_list)
let send_param msg = e_constructor "Send" msg
let withdraw_param = e_constructor "Withdraw" empty_message