change passes name concrete_to_imperative, imperative_to_sugar, sugar_to_core

This commit is contained in:
Pierre-Emmanuel Wulfman 2020-03-16 14:53:56 +01:00
parent 8b3877a92c
commit 6dd7afbeb1
22 changed files with 408 additions and 408 deletions

View File

@ -10,6 +10,6 @@ Its files are in `parser/parser_name`.
## Concrete Syntax Tree ## Concrete Syntax Tree
The CST is the aforementioned structured representation of the program. Is is structurally very close to the source code, and is mostly an intermediary there because manipulating string is not practical. The CST is the aforementioned structured representation of the program. Is is structurally very close to the source code, and is mostly an intermediary there because manipulating string is not practical.
Its files are in `parser/parser_name`. Its files are in `parser/parser_name`.
## Simplifier ## Sugar_to_core
A Simplifier is a function that takes a CST and outputs the corresponding Common AST. This is the actual bridge between a given syntax and LIGO. A Sugar_to_core is a function that takes a CST and outputs the corresponding Common AST. This is the actual bridge between a given syntax and LIGO.
Its files are in `simplify/parser_name`. Its files are in `simplify/parser_name`.

View File

@ -363,8 +363,8 @@ let run_function =
let%bind failstring = Run.failwith_to_string fail_res in let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring ok @@ Format.asprintf "%s" failstring
| Success michelson_output -> | Success michelson_output ->
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in let%bind core_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_core.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
in in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
@ -381,8 +381,8 @@ let evaluate_value =
let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
let%bind michelson_output = Run.run_no_failwith ~options compiled.expr compiled.expr_ty in let%bind michelson_output = Run.run_no_failwith ~options compiled.expr compiled.expr_ty in
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in let%bind core_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in
ok @@ Format.asprintf "%a\n" Ast_core.PP.expression simplified_output ok @@ Format.asprintf "%a\n" Ast_core.PP.expression core_output
in in
let term = let term =
Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in

View File

@ -5,13 +5,13 @@
simple-utils simple-utils
tezos-utils tezos-utils
parser parser
abstracter concrete_to_imperative
ast_imperative ast_imperative
self_ast_imperative self_ast_imperative
instruction_remover imperative_to_sugar
ast_sugar ast_sugar
self_ast_sugar self_ast_sugar
simplifier sugar_to_core
ast_core ast_core
self_ast_core self_ast_core
typer_new typer_new

View File

@ -25,7 +25,7 @@ let parsify_pascaligo source =
Parser.Pascaligo.parse_file source in Parser.Pascaligo.parse_file source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting") @@ trace (simple_error "abstracting") @@
Abstracter.Pascaligo.abstr_program raw Concrete_to_imperative.Pascaligo.compile_program raw
in ok imperative in ok imperative
let parsify_expression_pascaligo source = let parsify_expression_pascaligo source =
@ -34,7 +34,7 @@ let parsify_expression_pascaligo source =
Parser.Pascaligo.parse_expression source in Parser.Pascaligo.parse_expression source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting expression") @@ trace (simple_error "abstracting expression") @@
Abstracter.Pascaligo.abstr_expression raw Concrete_to_imperative.Pascaligo.compile_expression raw
in ok imperative in ok imperative
let parsify_cameligo source = let parsify_cameligo source =
@ -43,7 +43,7 @@ let parsify_cameligo source =
Parser.Cameligo.parse_file source in Parser.Cameligo.parse_file source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting") @@ trace (simple_error "abstracting") @@
Abstracter.Cameligo.abstr_program raw Concrete_to_imperative.Cameligo.compile_program raw
in ok imperative in ok imperative
let parsify_expression_cameligo source = let parsify_expression_cameligo source =
@ -52,7 +52,7 @@ let parsify_expression_cameligo source =
Parser.Cameligo.parse_expression source in Parser.Cameligo.parse_expression source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting expression") @@ trace (simple_error "abstracting expression") @@
Abstracter.Cameligo.abstr_expression raw Concrete_to_imperative.Cameligo.compile_expression raw
in ok imperative in ok imperative
let parsify_reasonligo source = let parsify_reasonligo source =
@ -61,7 +61,7 @@ let parsify_reasonligo source =
Parser.Reasonligo.parse_file source in Parser.Reasonligo.parse_file source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting") @@ trace (simple_error "abstracting") @@
Abstracter.Cameligo.abstr_program raw Concrete_to_imperative.Cameligo.compile_program raw
in ok imperative in ok imperative
let parsify_expression_reasonligo source = let parsify_expression_reasonligo source =
@ -70,7 +70,7 @@ let parsify_expression_reasonligo source =
Parser.Reasonligo.parse_expression source in Parser.Reasonligo.parse_expression source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting expression") @@ trace (simple_error "abstracting expression") @@
Abstracter.Cameligo.abstr_expression raw Concrete_to_imperative.Cameligo.compile_expression raw
in ok imperative in ok imperative
let parsify syntax source = let parsify syntax source =
@ -98,7 +98,7 @@ let parsify_string_reasonligo source =
Parser.Reasonligo.parse_string source in Parser.Reasonligo.parse_string source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting") @@ trace (simple_error "abstracting") @@
Abstracter.Cameligo.abstr_program raw Concrete_to_imperative.Cameligo.compile_program raw
in ok imperative in ok imperative
let parsify_string_pascaligo source = let parsify_string_pascaligo source =
@ -107,7 +107,7 @@ let parsify_string_pascaligo source =
Parser.Pascaligo.parse_string source in Parser.Pascaligo.parse_string source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting") @@ trace (simple_error "abstracting") @@
Abstracter.Pascaligo.abstr_program raw Concrete_to_imperative.Pascaligo.compile_program raw
in ok imperative in ok imperative
let parsify_string_cameligo source = let parsify_string_cameligo source =
@ -116,7 +116,7 @@ let parsify_string_cameligo source =
Parser.Cameligo.parse_string source in Parser.Cameligo.parse_string source in
let%bind imperative = let%bind imperative =
trace (simple_error "abstracting") @@ trace (simple_error "abstracting") @@
Abstracter.Cameligo.abstr_program raw Concrete_to_imperative.Cameligo.compile_program raw
in ok imperative in ok imperative
let parsify_string syntax source = let parsify_string syntax source =

View File

@ -1,16 +1,16 @@
open Trace open Trace
open Ast_imperative open Ast_imperative
open Instruction_remover open Imperative_to_sugar
type form = type form =
| Contract of string | Contract of string
| Env | Env
let compile (program : program) : Ast_sugar.program result = let compile (program : program) : Ast_sugar.program result =
remove_instruction_in_program program compile_program program
let compile_expression (e : expression) : Ast_sugar.expression result = let compile_expression (e : expression) : Ast_sugar.expression result =
remove_instruction_in_expression e compile_expression e
let pretty_print formatter (program : program) = let pretty_print formatter (program : program) =
PP.program formatter program PP.program formatter program

View File

@ -1,16 +1,16 @@
open Trace open Trace
open Ast_sugar open Ast_sugar
open Simplifier open Sugar_to_core
type form = type form =
| Contract of string | Contract of string
| Env | Env
let compile (program : program) : Ast_core.program result = let compile (program : program) : Ast_core.program result =
simplify_program program compile_program program
let compile_expression (e : expression) : Ast_core.expression result = let compile_expression (e : expression) : Ast_core.expression result =
simplify_expression e compile_expression e
let pretty_print formatter (program : program) = let pretty_print formatter (program : program) =
PP.program formatter program PP.program formatter program

View File

@ -5,9 +5,9 @@
simple-utils simple-utils
tezos-utils tezos-utils
parser parser
abstracter concrete_to_imperative
self_ast_imperative self_ast_imperative
simplifier sugar_to_core
ast_core ast_core
typer_new typer_new
typer typer

View File

@ -156,7 +156,7 @@ end
open Errors open Errors
open Operators.Abstracter.Cameligo open Operators.Concrete_to_imperative.Cameligo
let r_split = Location.r_split let r_split = Location.r_split
@ -205,7 +205,7 @@ let rec typed_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern ->
| Raw.PTyped pt -> | Raw.PTyped pt ->
let (p,t) = pt.value.pattern,pt.value.type_expr in let (p,t) = pt.value.pattern,pt.value.type_expr in
let%bind p = tuple_pattern_to_vars p in let%bind p = tuple_pattern_to_vars p in
let%bind t = abstr_type_expression t in let%bind t = compile_type_expression t in
ok @@ (p,t) ok @@ (p,t)
| other -> (fail @@ wrong_pattern "parenthetical or type annotation" other) | other -> (fail @@ wrong_pattern "parenthetical or type annotation" other)
@ -213,10 +213,10 @@ and unpar_pattern : Raw.pattern -> Raw.pattern = function
| PPar p -> unpar_pattern p.value.inside | PPar p -> unpar_pattern p.value.inside
| _ as p -> p | _ as p -> p
and abstr_type_expression : Raw.type_expr -> type_expression result = fun te -> and compile_type_expression : Raw.type_expr -> type_expression result = fun te ->
trace (simple_info "abstracting this type expression...") @@ trace (simple_info "abstracting this type expression...") @@
match te with match te with
TPar x -> abstr_type_expression x.value.inside TPar x -> compile_type_expression x.value.inside
| TVar v -> ( | TVar v -> (
match type_constants v.value with match type_constants v.value with
| Ok (s,_) -> ok @@ make_t @@ T_constant s | Ok (s,_) -> ok @@ make_t @@ T_constant s
@ -225,8 +225,8 @@ and abstr_type_expression : Raw.type_expr -> type_expression result = fun te ->
| TFun x -> ( | TFun x -> (
let%bind (type1 , type2) = let%bind (type1 , type2) =
let (a , _ , b) = x.value in let (a , _ , b) = x.value in
let%bind a = abstr_type_expression a in let%bind a = compile_type_expression a in
let%bind b = abstr_type_expression b in let%bind b = compile_type_expression b in
ok (a , b) ok (a , b)
in in
ok @@ make_t @@ T_arrow {type1;type2} ok @@ make_t @@ T_arrow {type1;type2}
@ -234,18 +234,18 @@ and abstr_type_expression : Raw.type_expr -> type_expression result = fun te ->
| TApp x -> ( | TApp x -> (
let (name, tuple) = x.value in let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside in let lst = npseq_to_list tuple.value.inside in
let%bind lst' = bind_map_list abstr_type_expression lst in let%bind lst' = bind_map_list compile_type_expression lst in
let%bind cst = let%bind cst =
trace (unknown_predefined_type name) @@ trace (unknown_predefined_type name) @@
type_operators name.value in type_operators name.value in
t_operator cst lst' t_operator cst lst'
) )
| TProd p -> ( | TProd p -> (
let%bind tpl = abstr_list_type_expression @@ npseq_to_list p.value in let%bind tpl = compile_list_type_expression @@ npseq_to_list p.value in
ok tpl ok tpl
) )
| TRecord r -> | TRecord r ->
let aux = fun (x, y) -> let%bind y = abstr_type_expression y in ok (x, y) in let aux = fun (x, y) -> let%bind y = compile_type_expression y in ok (x, y) in
let apply (x:Raw.field_decl Raw.reg) = let apply (x:Raw.field_decl Raw.reg) =
(x.value.field_name.value, x.value.field_type) in (x.value.field_name.value, x.value.field_type) in
let%bind lst = let%bind lst =
@ -262,7 +262,7 @@ and abstr_type_expression : Raw.type_expr -> type_expression result = fun te ->
None -> [] None -> []
| Some (_, TProd product) -> npseq_to_list product.value | Some (_, TProd product) -> npseq_to_list product.value
| Some (_, t_expr) -> [t_expr] in | Some (_, t_expr) -> [t_expr] in
let%bind te = abstr_list_type_expression @@ args in let%bind te = compile_list_type_expression @@ args in
ok (v.value.constr.value, te) in ok (v.value.constr.value, te) in
let%bind lst = bind_list let%bind lst = bind_list
@@ List.map aux @@ List.map aux
@ -270,18 +270,18 @@ and abstr_type_expression : Raw.type_expr -> type_expression result = fun te ->
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t @@ T_sum m ok @@ make_t @@ T_sum m
and abstr_list_type_expression (lst:Raw.type_expr list) : type_expression result = and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with match lst with
| [] -> ok @@ t_unit | [] -> ok @@ t_unit
| [hd] -> abstr_type_expression hd | [hd] -> compile_type_expression hd
| lst -> | lst ->
let%bind lst = bind_map_list abstr_type_expression lst in let%bind lst = bind_map_list compile_type_expression lst in
ok @@ t_tuple lst ok @@ t_tuple lst
let rec abstr_expression : let rec compile_expression :
Raw.expr -> expr result = fun t -> Raw.expr -> expr result = fun t ->
let return x = ok x in let return x = ok x in
let abstr_projection = fun (p:Raw.projection Region.reg) -> let compile_projection = fun (p:Raw.projection Region.reg) ->
let (p , loc) = r_split p in let (p , loc) = r_split p in
let var = let var =
let name = Var.of_name p.struct_name.value in let name = Var.of_name p.struct_name.value in
@ -296,7 +296,7 @@ let rec abstr_expression :
List.map aux @@ npseq_to_list path in List.map aux @@ npseq_to_list path in
return @@ List.fold_left (e_accessor ~loc ) var path' return @@ List.fold_left (e_accessor ~loc ) var path'
in in
let abstr_path : Raw.path -> string * label list = fun p -> let compile_path : Raw.path -> string * label list = fun p ->
match p with match p with
| Raw.Name v -> (v.value , []) | Raw.Name v -> (v.value , [])
| Raw.Path p -> ( | Raw.Path p -> (
@ -313,9 +313,9 @@ let rec abstr_expression :
(var , path') (var , path')
) )
in in
let abstr_update = fun (u:Raw.update Region.reg) -> let compile_update = fun (u:Raw.update Region.reg) ->
let (u, loc) = r_split u in let (u, loc) = r_split u in
let (name, path) = abstr_path u.record in let (name, path) = compile_path u.record in
let record = match path with let record = match path with
| [] -> e_variable (Var.of_name name) | [] -> e_variable (Var.of_name name)
| _ -> | _ ->
@ -325,7 +325,7 @@ let rec abstr_expression :
let%bind updates' = let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) = let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f in let (f,_) = r_split f in
let%bind expr = abstr_expression f.field_expr in let%bind expr = compile_expression f.field_expr in
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr)
in in
bind_map_list aux @@ npseq_to_list updates bind_map_list aux @@ npseq_to_list updates
@ -352,20 +352,20 @@ let rec abstr_expression :
| (p, []) -> | (p, []) ->
let%bind variables = tuple_pattern_to_typed_vars p in let%bind variables = tuple_pattern_to_typed_vars p in
let%bind ty_opt = let%bind ty_opt =
bind_map_option (fun (_,te) -> abstr_type_expression te) lhs_type in bind_map_option (fun (_,te) -> compile_type_expression te) lhs_type in
let%bind rhs = abstr_expression let_rhs in let%bind rhs = compile_expression let_rhs in
let rhs_b = Var.fresh ~name: "rhs" () in let rhs_b = Var.fresh ~name: "rhs" () in
let rhs',rhs_b_expr = let rhs',rhs_b_expr =
match ty_opt with match ty_opt with
None -> rhs, e_variable rhs_b None -> rhs, e_variable rhs_b
| Some ty -> (e_annotation rhs ty), e_annotation (e_variable rhs_b) ty in | Some ty -> (e_annotation rhs ty), e_annotation (e_variable rhs_b) ty in
let%bind body = abstr_expression body in let%bind body = compile_expression body in
let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) = let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) =
let variable, ty_opt = ty_var in let variable, ty_opt = ty_var in
let var_expr = Var.of_name variable.value in let var_expr = Var.of_name variable.value in
let%bind ty_expr_opt = let%bind ty_expr_opt =
match ty_opt with match ty_opt with
| Some ty -> bind_map_option abstr_type_expression (Some ty) | Some ty -> bind_map_option compile_type_expression (Some ty)
| None -> ok None | None -> ok None
in ok (var_expr, ty_expr_opt) in ok (var_expr, ty_expr_opt)
in in
@ -397,7 +397,7 @@ let rec abstr_expression :
| None -> (match let_rhs with | None -> (match let_rhs with
| EFun {value={binders;lhs_type}} -> | EFun {value={binders;lhs_type}} ->
let f_args = nseq_to_list (binders) in let f_args = nseq_to_list (binders) in
let%bind lhs_type' = bind_map_option (fun x -> abstr_type_expression (snd x)) lhs_type in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in
let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args 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 let aux acc ty = Option.map (t_function (snd ty)) acc in
ok @@ (List.fold_right' aux lhs_type' ty) ok @@ (List.fold_right' aux lhs_type' ty)
@ -444,8 +444,8 @@ let rec abstr_expression :
end end
| Raw.EAnnot a -> | Raw.EAnnot a ->
let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in
let%bind expr' = abstr_expression expr in let%bind expr' = compile_expression expr in
let%bind type_expr' = abstr_type_expression type_expr in let%bind type_expr' = compile_type_expression type_expr in
return @@ e_annotation ~loc expr' type_expr' return @@ e_annotation ~loc expr' type_expr'
| EVar c -> | EVar c ->
let (c',loc) = r_split c in let (c',loc) = r_split c in
@ -454,7 +454,7 @@ let rec abstr_expression :
| Ok (s,_) -> return @@ e_constant s []) | Ok (s,_) -> return @@ e_constant s [])
| ECall x -> ( | ECall x -> (
let ((e1 , e2) , loc) = r_split x in let ((e1 , e2) , loc) = r_split x in
let%bind args = bind_map_list abstr_expression (nseq_to_list e2) in let%bind args = bind_map_list compile_expression (nseq_to_list e2) in
let rec chain_application (f: expression) (args: expression list) = let rec chain_application (f: expression) (args: expression list) =
match args with match args with
| hd :: tl -> chain_application (e_application ~loc f hd) tl | hd :: tl -> chain_application (e_application ~loc f hd) tl
@ -468,29 +468,29 @@ let rec abstr_expression :
| Ok (s, _) -> return @@ e_constant ~loc s args | Ok (s, _) -> return @@ e_constant ~loc s args
) )
| e1 -> | e1 ->
let%bind e1' = abstr_expression e1 in let%bind e1' = compile_expression e1 in
return @@ chain_application e1' args return @@ chain_application e1' args
) )
| EPar x -> abstr_expression x.value.inside | EPar x -> compile_expression x.value.inside
| EUnit reg -> | EUnit reg ->
let (_ , loc) = r_split reg in let (_ , loc) = r_split reg in
return @@ e_literal ~loc Literal_unit return @@ e_literal ~loc Literal_unit
| EBytes x -> | EBytes x ->
let (x , loc) = r_split x in let (x , loc) = r_split x in
return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x)) return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x))
| ETuple tpl -> abstr_tuple_expression @@ (npseq_to_list tpl.value) | ETuple tpl -> compile_tuple_expression @@ (npseq_to_list tpl.value)
| ERecord r -> | ERecord r ->
let (r , loc) = r_split r in let (r , loc) = r_split r in
let%bind fields = bind_list let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = abstr_expression v in ok (k.value, v)) @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = compile_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ npseq_to_list r.ne_elements in @@ npseq_to_list r.ne_elements in
return @@ e_record_ez ~loc fields return @@ e_record_ez ~loc fields
| EProj p -> abstr_projection p | EProj p -> compile_projection p
| EUpdate u -> abstr_update u | EUpdate u -> compile_update u
| EConstr (ESomeApp a) -> | EConstr (ESomeApp a) ->
let (_, args), loc = r_split a in let (_, args), loc = r_split a in
let%bind arg = abstr_expression args in let%bind arg = compile_expression args in
return @@ e_constant ~loc C_SOME [arg] return @@ e_constant ~loc C_SOME [arg]
| EConstr (ENone reg) -> | EConstr (ENone reg) ->
let loc = Location.lift reg in let loc = Location.lift reg in
@ -502,18 +502,18 @@ let rec abstr_expression :
match args with match args with
None -> [] None -> []
| Some arg -> [arg] in | Some arg -> [arg] in
let%bind arg = abstr_tuple_expression @@ args let%bind arg = compile_tuple_expression @@ args
in return @@ e_constructor ~loc c_name arg in return @@ e_constructor ~loc c_name arg
| EArith (Add c) -> | EArith (Add c) ->
abstr_binop "ADD" c compile_binop "ADD" c
| EArith (Sub c) -> | EArith (Sub c) ->
abstr_binop "SUB" c compile_binop "SUB" c
| EArith (Mult c) -> | EArith (Mult c) ->
abstr_binop "TIMES" c compile_binop "TIMES" c
| EArith (Div c) -> | EArith (Div c) ->
abstr_binop "DIV" c compile_binop "DIV" c
| EArith (Mod c) -> | EArith (Mod c) ->
abstr_binop "MOD" c compile_binop "MOD" c
| EArith (Int n) -> ( | EArith (Int n) -> (
let (n , loc) = r_split n in let (n , loc) = r_split n in
let n = Z.to_int @@ snd @@ n in let n = Z.to_int @@ snd @@ n in
@ -529,7 +529,7 @@ let rec abstr_expression :
let n = Z.to_int @@ snd @@ n in let n = Z.to_int @@ snd @@ n in
return @@ e_literal ~loc (Literal_mutez n) return @@ e_literal ~loc (Literal_mutez n)
) )
| EArith (Neg e) -> abstr_unop "NEG" e | EArith (Neg e) -> compile_unop "NEG" e
| EString (String s) -> ( | EString (String s) -> (
let (s , loc) = r_split s in let (s , loc) = r_split s in
let s' = let s' =
@ -540,24 +540,24 @@ let rec abstr_expression :
) )
| EString (Cat c) -> | EString (Cat c) ->
let (c, loc) = r_split c in let (c, loc) = r_split c in
let%bind string_left = abstr_expression c.arg1 in let%bind string_left = compile_expression c.arg1 in
let%bind string_right = abstr_expression c.arg2 in let%bind string_right = compile_expression c.arg2 in
return @@ e_string_cat ~loc string_left string_right return @@ e_string_cat ~loc string_left string_right
| ELogic l -> abstr_logic_expression l | ELogic l -> compile_logic_expression l
| EList l -> abstr_list_expression l | EList l -> compile_list_expression l
| ECase c -> ( | ECase c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind e = abstr_expression c.expr in let%bind e = compile_expression c.expr in
let%bind lst = let%bind lst =
let aux (x : Raw.expr Raw.case_clause) = let aux (x : Raw.expr Raw.case_clause) =
let%bind expr = abstr_expression x.rhs in let%bind expr = compile_expression x.rhs in
ok (x.pattern, expr) in ok (x.pattern, expr) in
bind_list bind_list
@@ List.map aux @@ List.map aux
@@ List.map get_value @@ List.map get_value
@@ npseq_to_list c.cases.value in @@ npseq_to_list c.cases.value in
let default_action () = let default_action () =
let%bind cases = abstr_cases lst in let%bind cases = compile_cases lst in
return @@ e_matching ~loc e cases in return @@ e_matching ~loc e cases in
(* Hack to take care of patterns introduced by `parser/cameligo/Parser.mly` in "norm_fun_expr". TODO: Still needed? *) (* Hack to take care of patterns introduced by `parser/cameligo/Parser.mly` in "norm_fun_expr". TODO: Still needed? *)
match lst with match lst with
@ -571,7 +571,7 @@ let rec abstr_expression :
match x'.pattern with match x'.pattern with
| Raw.PVar y -> | Raw.PVar y ->
let var_name = Var.of_name y.value in let var_name = Var.of_name y.value in
let%bind type_expr = abstr_type_expression x'.type_expr in let%bind type_expr = compile_type_expression x'.type_expr in
return @@ e_let_in (var_name , Some type_expr) false false e rhs return @@ e_let_in (var_name , Some type_expr) false false e rhs
| _ -> default_action () | _ -> default_action ()
) )
@ -581,29 +581,29 @@ let rec abstr_expression :
) )
| _ -> default_action () | _ -> default_action ()
) )
| EFun lamb -> abstr_fun lamb | EFun lamb -> compile_fun lamb
| ESeq s -> ( | ESeq s -> (
let (s , loc) = r_split s in let (s , loc) = r_split s in
let items : Raw.expr list = pseq_to_list s.elements in let items : Raw.expr list = pseq_to_list s.elements in
(match items with (match items with
[] -> return @@ e_skip ~loc () [] -> return @@ e_skip ~loc ()
| expr::more -> | expr::more ->
let expr' = abstr_expression expr in let expr' = compile_expression expr in
let apply (e1: Raw.expr) (e2: expression Trace.result) = let apply (e1: Raw.expr) (e2: expression Trace.result) =
let%bind a = abstr_expression e1 in let%bind a = compile_expression e1 in
let%bind e2' = e2 in let%bind e2' = e2 in
return @@ e_sequence a e2' return @@ e_sequence a e2'
in List.fold_right apply more expr') in List.fold_right apply more expr')
) )
| ECond c -> ( | ECond c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = abstr_expression c.test in let%bind expr = compile_expression c.test in
let%bind match_true = abstr_expression c.ifso in let%bind match_true = compile_expression c.ifso in
let%bind match_false = abstr_expression c.ifnot in let%bind match_false = compile_expression c.ifnot in
return @@ e_matching ~loc expr (Match_bool {match_true; match_false}) return @@ e_matching ~loc expr (Match_bool {match_true; match_false})
) )
and abstr_fun lamb' : expr result = and compile_fun lamb' : expr result =
let return x = ok x in let return x = ok x in
let (lamb , loc) = r_split lamb' in let (lamb , loc) = r_split lamb' in
let%bind params' = let%bind params' =
@ -649,7 +649,7 @@ and abstr_fun lamb' : expr result =
| _ , None -> | _ , None ->
fail @@ untyped_fun_param var fail @@ untyped_fun_param var
| _ , Some ty -> ( | _ , Some ty -> (
let%bind ty' = abstr_type_expression ty in let%bind ty' = compile_type_expression ty in
ok (var , ty') ok (var , ty')
) )
in in
@ -700,8 +700,8 @@ and abstr_fun lamb' : expr result =
in in
let%bind (body , body_type) = expr_to_typed_expr body in let%bind (body , body_type) = expr_to_typed_expr body in
let%bind output_type = let%bind output_type =
bind_map_option abstr_type_expression body_type in bind_map_option compile_type_expression body_type in
let%bind body = abstr_expression body in let%bind body = compile_expression body in
let rec layer_arguments (arguments: (Raw.variable * type_expression) list) = let rec layer_arguments (arguments: (Raw.variable * type_expression) list) =
match arguments with match arguments with
| hd :: tl -> | hd :: tl ->
@ -714,7 +714,7 @@ and abstr_fun lamb' : expr result =
return @@ ret_lamb return @@ ret_lamb
and abstr_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = and compile_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
let return x = ok @@ make_option_typed x te_annot in let return x = ok @@ make_option_typed x te_annot in
match t with match t with
| BoolExpr (False reg) -> ( | BoolExpr (False reg) -> (
@ -726,61 +726,61 @@ and abstr_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
return @@ e_literal ~loc (Literal_bool true) return @@ e_literal ~loc (Literal_bool true)
) )
| BoolExpr (Or b) -> | BoolExpr (Or b) ->
abstr_binop "OR" b compile_binop "OR" b
| BoolExpr (And b) -> | BoolExpr (And b) ->
abstr_binop "AND" b compile_binop "AND" b
| BoolExpr (Not b) -> | BoolExpr (Not b) ->
abstr_unop "NOT" b compile_unop "NOT" b
| CompExpr (Lt c) -> | CompExpr (Lt c) ->
abstr_binop "LT" c compile_binop "LT" c
| CompExpr (Gt c) -> | CompExpr (Gt c) ->
abstr_binop "GT" c compile_binop "GT" c
| CompExpr (Leq c) -> | CompExpr (Leq c) ->
abstr_binop "LE" c compile_binop "LE" c
| CompExpr (Geq c) -> | CompExpr (Geq c) ->
abstr_binop "GE" c compile_binop "GE" c
| CompExpr (Equal c) -> | CompExpr (Equal c) ->
abstr_binop "EQ" c compile_binop "EQ" c
| CompExpr (Neq c) -> | CompExpr (Neq c) ->
abstr_binop "NEQ" c compile_binop "NEQ" c
and abstr_list_expression (t:Raw.list_expr) : expression result = and compile_list_expression (t:Raw.list_expr) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
match t with match t with
ECons c -> abstr_binop "CONS" c ECons c -> compile_binop "CONS" c
| EListComp lst -> ( | EListComp lst -> (
let (lst , loc) = r_split lst in let (lst , loc) = r_split lst in
let%bind lst' = let%bind lst' =
bind_map_list abstr_expression @@ bind_map_list compile_expression @@
pseq_to_list lst.elements in pseq_to_list lst.elements in
return @@ e_list ~loc lst' return @@ e_list ~loc lst'
) )
and abstr_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
let (args , loc) = r_split t in let (args , loc) = r_split t in
let%bind a = abstr_expression args.arg1 in let%bind a = compile_expression args.arg1 in
let%bind b = abstr_expression args.arg2 in let%bind b = compile_expression args.arg2 in
let%bind name = constants name in let%bind name = constants name in
return @@ e_constant ~loc name [ a ; b ] return @@ e_constant ~loc name [ a ; b ]
and abstr_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = abstr_expression t.arg in let%bind a = compile_expression t.arg in
let%bind name = constants name in let%bind name = constants name in
return @@ e_constant ~loc name [ a ] return @@ e_constant ~loc name [ a ]
and abstr_tuple_expression ?loc (lst:Raw.expr list) : expression result = and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
let return x = ok @@ x in let return x = ok @@ x in
match lst with match lst with
| [] -> return @@ e_literal ?loc Literal_unit | [] -> return @@ e_literal ?loc Literal_unit
| [hd] -> abstr_expression hd | [hd] -> compile_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map abstr_expression lst in let%bind lst = bind_list @@ List.map compile_expression lst in
return @@ e_tuple ?loc lst return @@ e_tuple ?loc lst
and abstr_declaration : Raw.declaration -> declaration Location.wrap list result = and compile_declaration : Raw.declaration -> declaration Location.wrap list result =
fun t -> fun t ->
let open! Raw in let open! Raw in
let loc : 'a . 'a Raw.reg -> _ -> _ = let loc : 'a . 'a Raw.reg -> _ -> _ =
@ -788,7 +788,7 @@ and abstr_declaration : Raw.declaration -> declaration Location.wrap list result
match t with match t with
| TypeDecl x -> | TypeDecl x ->
let {name;type_expr} : Raw.type_decl = x.value in let {name;type_expr} : Raw.type_decl = x.value in
let%bind type_expression = abstr_type_expression type_expr in let%bind type_expression = compile_type_expression type_expr in
ok @@ [loc x @@ Declaration_type (Var.of_name name.value , type_expression)] ok @@ [loc x @@ Declaration_type (Var.of_name name.value , type_expression)]
| Let x -> ( | Let x -> (
let (_, recursive, let_binding, attributes), _ = r_split x in let (_, recursive, let_binding, attributes), _ = r_split x in
@ -803,11 +803,11 @@ and abstr_declaration : Raw.declaration -> declaration Location.wrap list result
let%bind (v, v_type) = pattern_to_typed_var par_var in let%bind (v, v_type) = pattern_to_typed_var par_var in
let%bind v_type_expression = let%bind v_type_expression =
match v_type with match v_type with
| Some v_type -> ok (to_option (abstr_type_expression v_type)) | Some v_type -> ok (to_option (compile_type_expression v_type))
| None -> ok None | None -> ok None
in in
let%bind abstr_rhs_expr = abstr_expression rhs_expr in let%bind compile_rhs_expr = compile_expression rhs_expr in
ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, abstr_rhs_expr) ) ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, compile_rhs_expr) )
in let%bind variables = ok @@ npseq_to_list pt.value in let%bind variables = ok @@ npseq_to_list pt.value
in let%bind expr_bind_lst = in let%bind expr_bind_lst =
match let_rhs with match let_rhs with
@ -847,7 +847,7 @@ and abstr_declaration : Raw.declaration -> declaration Location.wrap list result
| PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } -> | PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } ->
(* Extract parenthetical multi-bind *) (* Extract parenthetical multi-bind *)
let (wild, recursive, _, attributes) = fst @@ r_split x in let (wild, recursive, _, attributes) = fst @@ r_split x in
abstr_declaration compile_declaration
(Let { (Let {
region = x.region; region = x.region;
value = (wild, recursive, {binders = (pt, []); value = (wild, recursive, {binders = (pt, []);
@ -862,7 +862,7 @@ and abstr_declaration : Raw.declaration -> declaration Location.wrap list result
let%bind var = pattern_to_var hd in let%bind var = pattern_to_var hd in
ok (var , tl) ok (var , tl)
in in
let%bind lhs_type' = bind_map_option (fun x -> abstr_type_expression (snd x)) lhs_type in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in
let%bind let_rhs,lhs_type = match args with let%bind let_rhs,lhs_type = match args with
| [] -> ok (let_rhs, lhs_type') | [] -> ok (let_rhs, lhs_type')
| param1::others -> | param1::others ->
@ -878,12 +878,12 @@ and abstr_declaration : Raw.declaration -> declaration Location.wrap list result
let aux acc ty = Option.map (t_function (snd ty)) acc in let aux acc ty = Option.map (t_function (snd ty)) acc in
ok (Raw.EFun {region=Region.ghost ; value=fun_},List.fold_right' aux lhs_type' ty) ok (Raw.EFun {region=Region.ghost ; value=fun_},List.fold_right' aux lhs_type' ty)
in in
let%bind rhs' = abstr_expression let_rhs in let%bind rhs' = compile_expression let_rhs in
let%bind lhs_type = match lhs_type with let%bind lhs_type = match lhs_type with
| None -> (match let_rhs with | None -> (match let_rhs with
| EFun {value={binders;lhs_type}} -> | EFun {value={binders;lhs_type}} ->
let f_args = nseq_to_list (binders) in let f_args = nseq_to_list (binders) in
let%bind lhs_type' = bind_map_option (fun x -> abstr_type_expression (snd x)) lhs_type in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in
let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args 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 let aux acc ty = Option.map (t_function (snd ty)) acc in
ok @@ (List.fold_right' aux lhs_type' ty) ok @@ (List.fold_right' aux lhs_type' ty)
@ -906,7 +906,7 @@ and abstr_declaration : Raw.declaration -> declaration Location.wrap list result
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))] ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
) )
and abstr_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result = and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result =
fun t -> fun t ->
let open Raw in let open Raw in
let rec get_var (t:Raw.pattern) = let rec get_var (t:Raw.pattern) =
@ -1026,6 +1026,6 @@ and abstr_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content
| _ -> simple_fail "bad option pattern" | _ -> simple_fail "bad option pattern"
in bind_or (as_option () , as_variant ()) in bind_or (as_option () , as_variant ())
let abstr_program : Raw.ast -> program result = fun t -> let compile_program : Raw.ast -> program result = fun t ->
let%bind decls = bind_map_list abstr_declaration @@ nseq_to_list t.decl in let%bind decls = bind_map_list compile_declaration @@ nseq_to_list t.decl in
ok @@ List.concat @@ decls ok @@ List.concat @@ decls

View File

@ -45,18 +45,18 @@ val pattern_to_var : Raw.pattern -> Raw.variable result
val pattern_to_typed_var : Raw.pattern -> ( Raw.variable * Raw.type_expr option ) result val pattern_to_typed_var : Raw.pattern -> ( Raw.variable * Raw.type_expr option ) result
val expr_to_typed_expr : Raw.expr -> ( Raw.expr * Raw.type_expr option ) result val expr_to_typed_expr : Raw.expr -> ( Raw.expr * Raw.type_expr option ) result
val patterns_to_var : Raw.pattern list -> Raw.variable result val patterns_to_var : Raw.pattern list -> Raw.variable result
val abstr_type_expression : Raw.type_expr -> type_expression result val compile_type_expression : Raw.type_expr -> type_expression result
val abstr_list_type_expression : Raw.type_expr list -> type_expression result val compile_list_type_expression : Raw.type_expr list -> type_expression result
*) *)
val abstr_expression : Raw.expr -> expr result val compile_expression : Raw.expr -> expr result
(* (*
val abstr_fun : Raw.fun_expr Raw.reg -> expr result val compile_fun : Raw.fun_expr Raw.reg -> expr result
val abstr_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result val compile_logic_expression : ?te_annot:type_expression -> Raw.logic_expr -> expr result
val abstr_list_expression : Raw.list_expr -> expression result val compile_list_expression : Raw.list_expr -> expression result
val abstr_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result val compile_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result
val abstr_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result val compile_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result
val abstr_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result val compile_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result
val abstr_declaration : Raw.declaration -> declaration Location.wrap result val compile_declaration : Raw.declaration -> declaration Location.wrap result
val abstr_cases : (Raw.pattern * 'a) list -> 'a matching result val compile_cases : (Raw.pattern * 'a) list -> 'a matching result
*) *)
val abstr_program : Raw.ast -> program result val compile_program : Raw.ast -> program result

View File

@ -1,6 +1,6 @@
(library (library
(name abstracter) (name concrete_to_imperative)
(public_name ligo.abstracter) (public_name ligo.concrete_to_imperative)
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils
@ -8,7 +8,7 @@
ast_imperative ast_imperative
self_ast_imperative self_ast_imperative
operators) operators)
(modules cameligo pascaligo abstracter) (modules cameligo pascaligo concrete_to_imperative)
(preprocess (preprocess
(pps (pps
ppx_let ppx_let

View File

@ -199,7 +199,7 @@ module Errors = struct
end end
open Errors open Errors
open Operators.Abstracter.Pascaligo open Operators.Concrete_to_imperative.Pascaligo
let r_split = Location.r_split let r_split = Location.r_split
@ -229,9 +229,9 @@ let return_statement expr = ok @@ fun expr'_opt ->
| Some expr' -> ok @@ e_sequence expr expr' | Some expr' -> ok @@ e_sequence expr expr'
let rec abstr_type_expression (t:Raw.type_expr) : type_expression result = let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
match t with match t with
TPar x -> abstr_type_expression x.value.inside TPar x -> compile_type_expression x.value.inside
| TVar v -> ( | TVar v -> (
match type_constants v.value with match type_constants v.value with
| Ok (s,_) -> ok @@ make_t @@ T_constant s | Ok (s,_) -> ok @@ make_t @@ T_constant s
@ -240,25 +240,25 @@ let rec abstr_type_expression (t:Raw.type_expr) : type_expression result =
| TFun x -> ( | TFun x -> (
let%bind (a , b) = let%bind (a , b) =
let (a , _ , b) = x.value in let (a , _ , b) = x.value in
bind_map_pair abstr_type_expression (a , b) in bind_map_pair compile_type_expression (a , b) in
ok @@ make_t @@ T_arrow {type1=a;type2=b} ok @@ make_t @@ T_arrow {type1=a;type2=b}
) )
| TApp x -> | TApp x ->
let (name, tuple) = x.value in let (name, tuple) = x.value in
let lst = npseq_to_list tuple.value.inside in let lst = npseq_to_list tuple.value.inside in
let%bind lst = let%bind lst =
bind_list @@ List.map abstr_type_expression lst in (** TODO: fix constant and operator*) bind_list @@ List.map compile_type_expression lst in (** TODO: fix constant and operator*)
let%bind cst = let%bind cst =
trace (unknown_predefined_type name) @@ trace (unknown_predefined_type name) @@
type_operators name.value in type_operators name.value in
t_operator cst lst t_operator cst lst
| TProd p -> | TProd p ->
let%bind tpl = abstr_list_type_expression let%bind tpl = compile_list_type_expression
@@ npseq_to_list p.value in @@ npseq_to_list p.value in
ok tpl ok tpl
| TRecord r -> | TRecord r ->
let aux = fun (x, y) -> let aux = fun (x, y) ->
let%bind y = abstr_type_expression y in let%bind y = compile_type_expression y in
ok (x, y) ok (x, y)
in in
let apply = let apply =
@ -276,7 +276,7 @@ let rec abstr_type_expression (t:Raw.type_expr) : type_expression result =
None -> [] None -> []
| Some (_, TProd product) -> npseq_to_list product.value | Some (_, TProd product) -> npseq_to_list product.value
| Some (_, t_expr) -> [t_expr] in | Some (_, t_expr) -> [t_expr] in
let%bind te = abstr_list_type_expression @@ args in let%bind te = compile_list_type_expression @@ args in
ok (v.value.constr.value, te) ok (v.value.constr.value, te)
in in
let%bind lst = bind_list let%bind lst = bind_list
@ -285,15 +285,15 @@ let rec abstr_type_expression (t:Raw.type_expr) : type_expression result =
let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
ok @@ make_t @@ T_sum m ok @@ make_t @@ T_sum m
and abstr_list_type_expression (lst:Raw.type_expr list) : type_expression result = and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
match lst with match lst with
| [] -> ok @@ t_unit | [] -> ok @@ t_unit
| [hd] -> abstr_type_expression hd | [hd] -> compile_type_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map abstr_type_expression lst in let%bind lst = bind_list @@ List.map compile_type_expression lst in
ok @@ t_tuple lst ok @@ t_tuple lst
let abstr_projection : Raw.projection Region.reg -> _ = fun p -> let compile_projection : Raw.projection Region.reg -> _ = fun p ->
let (p' , loc) = r_split p in let (p' , loc) = r_split p in
let var = let var =
let name = Var.of_name p'.struct_name.value in let name = Var.of_name p'.struct_name.value in
@ -309,13 +309,13 @@ let abstr_projection : Raw.projection Region.reg -> _ = fun p ->
ok @@ List.fold_left (e_accessor ~loc) var path' ok @@ List.fold_left (e_accessor ~loc) var path'
let rec abstr_expression (t:Raw.expr) : expr result = let rec compile_expression (t:Raw.expr) : expr result =
let return x = ok x in let return x = ok x in
match t with match t with
| EAnnot a -> ( | EAnnot a -> (
let ((expr , type_expr) , loc) = r_split a in let ((expr , type_expr) , loc) = r_split a in
let%bind expr' = abstr_expression expr in let%bind expr' = compile_expression expr in
let%bind type_expr' = abstr_type_expression type_expr in let%bind type_expr' = compile_type_expression type_expr in
return @@ e_annotation ~loc expr' type_expr' return @@ e_annotation ~loc expr' type_expr'
) )
| EVar c -> ( | EVar c -> (
@ -333,19 +333,19 @@ let rec abstr_expression (t:Raw.expr) : expr result =
let (f_name , f_loc) = r_split name in let (f_name , f_loc) = r_split name in
match constants f_name with match constants f_name with
| Error _ -> | Error _ ->
let%bind arg = abstr_tuple_expression ~loc:args_loc args' in let%bind arg = compile_tuple_expression ~loc:args_loc args' in
return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg return @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
| Ok (s,_) -> | Ok (s,_) ->
let%bind lst = bind_map_list abstr_expression args' in let%bind lst = bind_map_list compile_expression args' in
return @@ e_constant ~loc s lst return @@ e_constant ~loc s lst
) )
| f -> ( | f -> (
let%bind f' = abstr_expression f in let%bind f' = compile_expression f in
let%bind arg = abstr_tuple_expression ~loc:args_loc args' in let%bind arg = compile_tuple_expression ~loc:args_loc args' in
return @@ e_application ~loc f' arg return @@ e_application ~loc f' arg
) )
) )
| EPar x -> abstr_expression x.value.inside | EPar x -> compile_expression x.value.inside
| EUnit reg -> | EUnit reg ->
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_literal ~loc Literal_unit return @@ e_literal ~loc Literal_unit
@ -354,16 +354,16 @@ let rec abstr_expression (t:Raw.expr) : expr result =
return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x')) return @@ e_literal ~loc (Literal_bytes (Hex.to_bytes @@ snd x'))
| ETuple tpl -> | ETuple tpl ->
let (tpl' , loc) = r_split tpl in let (tpl' , loc) = r_split tpl in
abstr_tuple_expression ~loc @@ npseq_to_list tpl'.inside compile_tuple_expression ~loc @@ npseq_to_list tpl'.inside
| ERecord r -> | ERecord r ->
let%bind fields = bind_list let%bind fields = bind_list
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = abstr_expression v in ok (k.value, v)) @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = compile_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ npseq_to_list r.value.ne_elements in @@ npseq_to_list r.value.ne_elements in
let aux prev (k, v) = SMap.add k v prev in let aux prev (k, v) = SMap.add k v prev in
return @@ e_record (List.fold_left aux SMap.empty fields) return @@ e_record (List.fold_left aux SMap.empty fields)
| EProj p -> abstr_projection p | EProj p -> compile_projection p
| EUpdate u -> abstr_update u | EUpdate u -> compile_update u
| EConstr (ConstrApp c) -> ( | EConstr (ConstrApp c) -> (
let ((c, args) , loc) = r_split c in let ((c, args) , loc) = r_split c in
match args with match args with
@ -372,7 +372,7 @@ let rec abstr_expression (t:Raw.expr) : expr result =
| Some args -> | Some args ->
let args, args_loc = r_split args in let args, args_loc = r_split args in
let%bind arg = let%bind arg =
abstr_tuple_expression ~loc:args_loc compile_tuple_expression ~loc:args_loc
@@ npseq_to_list args.inside in @@ npseq_to_list args.inside in
return @@ e_constructor ~loc c.value arg return @@ e_constructor ~loc c.value arg
) )
@ -380,7 +380,7 @@ let rec abstr_expression (t:Raw.expr) : expr result =
let ((_, args) , loc) = r_split a in let ((_, args) , loc) = r_split a in
let (args , args_loc) = r_split args in let (args , args_loc) = r_split args in
let%bind arg = let%bind arg =
abstr_tuple_expression ~loc:args_loc compile_tuple_expression ~loc:args_loc
@@ npseq_to_list args.inside in @@ npseq_to_list args.inside in
return @@ e_constant ~loc C_SOME [arg] return @@ e_constant ~loc C_SOME [arg]
| EConstr (NoneExpr reg) -> ( | EConstr (NoneExpr reg) -> (
@ -388,15 +388,15 @@ let rec abstr_expression (t:Raw.expr) : expr result =
return @@ e_none ~loc () return @@ e_none ~loc ()
) )
| EArith (Add c) -> | EArith (Add c) ->
abstr_binop "ADD" c compile_binop "ADD" c
| EArith (Sub c) -> | EArith (Sub c) ->
abstr_binop "SUB" c compile_binop "SUB" c
| EArith (Mult c) -> | EArith (Mult c) ->
abstr_binop "TIMES" c compile_binop "TIMES" c
| EArith (Div c) -> | EArith (Div c) ->
abstr_binop "DIV" c compile_binop "DIV" c
| EArith (Mod c) -> | EArith (Mod c) ->
abstr_binop "MOD" c compile_binop "MOD" c
| EArith (Int n) -> ( | EArith (Int n) -> (
let (n , loc) = r_split n in let (n , loc) = r_split n in
let n = Z.to_int @@ snd n in let n = Z.to_int @@ snd n in
@ -412,7 +412,7 @@ let rec abstr_expression (t:Raw.expr) : expr result =
let n = Z.to_int @@ snd @@ n in let n = Z.to_int @@ snd @@ n in
return @@ e_literal ~loc (Literal_mutez n) return @@ e_literal ~loc (Literal_mutez n)
) )
| EArith (Neg e) -> abstr_unop "NEG" e | EArith (Neg e) -> compile_unop "NEG" e
| EString (String s) -> | EString (String s) ->
let (s , loc) = r_split s in let (s , loc) = r_split s in
let s' = let s' =
@ -422,17 +422,17 @@ let rec abstr_expression (t:Raw.expr) : expr result =
return @@ e_literal ~loc (Literal_string s') return @@ e_literal ~loc (Literal_string s')
| EString (Cat bo) -> | EString (Cat bo) ->
let (bo , loc) = r_split bo in let (bo , loc) = r_split bo in
let%bind sl = abstr_expression bo.arg1 in let%bind sl = compile_expression bo.arg1 in
let%bind sr = abstr_expression bo.arg2 in let%bind sr = compile_expression bo.arg2 in
return @@ e_string_cat ~loc sl sr return @@ e_string_cat ~loc sl sr
| ELogic l -> abstr_logic_expression l | ELogic l -> compile_logic_expression l
| EList l -> abstr_list_expression l | EList l -> compile_list_expression l
| ESet s -> abstr_set_expression s | ESet s -> compile_set_expression s
| ECond c -> | ECond c ->
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = abstr_expression c.test in let%bind expr = compile_expression c.test in
let%bind match_true = abstr_expression c.ifso in let%bind match_true = compile_expression c.ifso in
let%bind match_false = abstr_expression c.ifnot in let%bind match_false = compile_expression c.ifnot in
let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in
let env = Var.fresh () in let env = Var.fresh () in
let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in
@ -440,16 +440,16 @@ let rec abstr_expression (t:Raw.expr) : expr result =
| ECase c -> ( | ECase c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind e = abstr_expression c.expr in let%bind e = compile_expression c.expr in
let%bind lst = let%bind lst =
let aux (x : Raw.expr Raw.case_clause) = let aux (x : Raw.expr Raw.case_clause) =
let%bind expr = abstr_expression x.rhs in let%bind expr = compile_expression x.rhs in
ok (x.pattern, expr) in ok (x.pattern, expr) in
bind_list bind_list
@@ List.map aux @@ List.map aux
@@ List.map get_value @@ List.map get_value
@@ npseq_to_list c.cases.value in @@ npseq_to_list c.cases.value in
let%bind cases = abstr_cases lst in let%bind cases = compile_cases lst in
let match_expr = e_matching ~loc e cases in let match_expr = e_matching ~loc e cases in
let env = Var.fresh () in let env = Var.fresh () in
let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in
@ -461,8 +461,8 @@ let rec abstr_expression (t:Raw.expr) : expr result =
let lst = List.map get_value @@ pseq_to_list mi.elements in let lst = List.map get_value @@ pseq_to_list mi.elements in
let aux : Raw.binding -> (expression * expression) result = let aux : Raw.binding -> (expression * expression) result =
fun b -> fun b ->
let%bind src = abstr_expression b.source in let%bind src = compile_expression b.source in
let%bind dst = abstr_expression b.image in let%bind dst = compile_expression b.image in
ok (src, dst) in ok (src, dst) in
bind_map_list aux lst in bind_map_list aux lst in
return @@ e_map ~loc lst return @@ e_map ~loc lst
@ -473,8 +473,8 @@ let rec abstr_expression (t:Raw.expr) : expr result =
let lst = List.map get_value @@ pseq_to_list mi.elements in let lst = List.map get_value @@ pseq_to_list mi.elements in
let aux : Raw.binding -> (expression * expression) result = let aux : Raw.binding -> (expression * expression) result =
fun b -> fun b ->
let%bind src = abstr_expression b.source in let%bind src = compile_expression b.source in
let%bind dst = abstr_expression b.image in let%bind dst = compile_expression b.image in
ok (src, dst) in ok (src, dst) in
bind_map_list aux lst in bind_map_list aux lst in
return @@ e_big_map ~loc lst return @@ e_big_map ~loc lst
@ -486,20 +486,20 @@ let rec abstr_expression (t:Raw.expr) : expr result =
let (v , loc) = r_split v in let (v , loc) = r_split v in
return @@ e_variable ~loc (Var.of_name v) return @@ e_variable ~loc (Var.of_name v)
) )
| Path p -> abstr_projection p | Path p -> compile_projection p
in in
let%bind index = abstr_expression lu.index.value.inside in let%bind index = compile_expression lu.index.value.inside in
return @@ e_look_up ~loc path index return @@ e_look_up ~loc path index
) )
| EFun f -> | EFun f ->
let (f , loc) = r_split f in let (f , loc) = r_split f in
let%bind (_ty_opt, f') = abstr_fun_expression ~loc f let%bind (_ty_opt, f') = compile_fun_expression ~loc f
in return @@ f' in return @@ f'
and abstr_update = fun (u:Raw.update Region.reg) -> and compile_update = fun (u:Raw.update Region.reg) ->
let (u, loc) = r_split u in let (u, loc) = r_split u in
let (name, path) = abstr_path u.record in let (name, path) = compile_path u.record in
let record = match path with let record = match path with
| [] -> e_variable (Var.of_name name) | [] -> e_variable (Var.of_name name)
| _ -> e_accessor_list (e_variable (Var.of_name name)) path in | _ -> e_accessor_list (e_variable (Var.of_name name)) path in
@ -507,7 +507,7 @@ and abstr_update = fun (u:Raw.update Region.reg) ->
let%bind updates' = let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) = let aux (f:Raw.field_path_assign Raw.reg) =
let (f,_) = r_split f in let (f,_) = r_split f in
let%bind expr = abstr_expression f.field_expr in let%bind expr = compile_expression f.field_expr in
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr) ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr)
in in
bind_map_list aux @@ npseq_to_list updates bind_map_list aux @@ npseq_to_list updates
@ -523,7 +523,7 @@ and abstr_update = fun (u:Raw.update Region.reg) ->
aux ur path in aux ur path in
bind_fold_list aux record updates' bind_fold_list aux record updates'
and abstr_logic_expression (t:Raw.logic_expr) : expression result = and compile_logic_expression (t:Raw.logic_expr) : expression result =
let return x = ok x in let return x = ok x in
match t with match t with
| BoolExpr (False reg) -> ( | BoolExpr (False reg) -> (
@ -535,92 +535,92 @@ and abstr_logic_expression (t:Raw.logic_expr) : expression result =
return @@ e_literal ~loc (Literal_bool true) return @@ e_literal ~loc (Literal_bool true)
) )
| BoolExpr (Or b) -> | BoolExpr (Or b) ->
abstr_binop "OR" b compile_binop "OR" b
| BoolExpr (And b) -> | BoolExpr (And b) ->
abstr_binop "AND" b compile_binop "AND" b
| BoolExpr (Not b) -> | BoolExpr (Not b) ->
abstr_unop "NOT" b compile_unop "NOT" b
| CompExpr (Lt c) -> | CompExpr (Lt c) ->
abstr_binop "LT" c compile_binop "LT" c
| CompExpr (Gt c) -> | CompExpr (Gt c) ->
abstr_binop "GT" c compile_binop "GT" c
| CompExpr (Leq c) -> | CompExpr (Leq c) ->
abstr_binop "LE" c compile_binop "LE" c
| CompExpr (Geq c) -> | CompExpr (Geq c) ->
abstr_binop "GE" c compile_binop "GE" c
| CompExpr (Equal c) -> | CompExpr (Equal c) ->
abstr_binop "EQ" c compile_binop "EQ" c
| CompExpr (Neq c) -> | CompExpr (Neq c) ->
abstr_binop "NEQ" c compile_binop "NEQ" c
and abstr_list_expression (t:Raw.list_expr) : expression result = and compile_list_expression (t:Raw.list_expr) : expression result =
let return x = ok x in let return x = ok x in
match t with match t with
ECons c -> ECons c ->
abstr_binop "CONS" c compile_binop "CONS" c
| EListComp lst -> | EListComp lst ->
let (lst , loc) = r_split lst in let (lst , loc) = r_split lst in
let%bind lst' = let%bind lst' =
bind_map_list abstr_expression @@ bind_map_list compile_expression @@
pseq_to_list lst.elements in pseq_to_list lst.elements in
return @@ e_list ~loc lst' return @@ e_list ~loc lst'
| ENil reg -> | ENil reg ->
let loc = Location.lift reg in let loc = Location.lift reg in
return @@ e_list ~loc [] return @@ e_list ~loc []
and abstr_set_expression (t:Raw.set_expr) : expression result = and compile_set_expression (t:Raw.set_expr) : expression result =
match t with match t with
| SetMem x -> ( | SetMem x -> (
let (x' , loc) = r_split x in let (x' , loc) = r_split x in
let%bind set' = abstr_expression x'.set in let%bind set' = compile_expression x'.set in
let%bind element' = abstr_expression x'.element in let%bind element' = compile_expression x'.element in
ok @@ e_constant ~loc C_SET_MEM [ element' ; set' ] ok @@ e_constant ~loc C_SET_MEM [ element' ; set' ]
) )
| SetInj x -> ( | SetInj x -> (
let (x' , loc) = r_split x in let (x' , loc) = r_split x in
let elements = pseq_to_list x'.elements in let elements = pseq_to_list x'.elements in
let%bind elements' = bind_map_list abstr_expression elements in let%bind elements' = bind_map_list compile_expression elements in
ok @@ e_set ~loc elements' ok @@ e_set ~loc elements'
) )
and abstr_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result = and compile_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let return x = ok x in let return x = ok x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = abstr_expression t.arg1 in let%bind a = compile_expression t.arg1 in
let%bind b = abstr_expression t.arg2 in let%bind b = compile_expression t.arg2 in
let%bind name = constants name in let%bind name = constants name in
return @@ e_constant ~loc name [ a ; b ] return @@ e_constant ~loc name [ a ; b ]
and abstr_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result = and compile_unop (name:string) (t:_ Raw.un_op Region.reg) : expression result =
let return x = ok x in let return x = ok x in
let (t , loc) = r_split t in let (t , loc) = r_split t in
let%bind a = abstr_expression t.arg in let%bind a = compile_expression t.arg in
let%bind name = constants name in let%bind name = constants name in
return @@ e_constant ~loc name [ a ] return @@ e_constant ~loc name [ a ]
and abstr_tuple_expression ?loc (lst:Raw.expr list) : expression result = and compile_tuple_expression ?loc (lst:Raw.expr list) : expression result =
let return x = ok x in let return x = ok x in
match lst with match lst with
| [] -> return @@ e_literal Literal_unit | [] -> return @@ e_literal Literal_unit
| [hd] -> abstr_expression hd | [hd] -> compile_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map abstr_expression lst let%bind lst = bind_list @@ List.map compile_expression lst
in return @@ e_tuple ?loc lst in return @@ e_tuple ?loc lst
and abstr_data_declaration : Raw.data_decl -> _ result = and compile_data_declaration : Raw.data_decl -> _ result =
fun t -> fun t ->
match t with match t with
| LocalVar x -> | LocalVar x ->
let (x , loc) = r_split x in let (x , loc) = r_split x in
let name = x.name.value in let name = x.name.value in
let%bind t = abstr_type_expression x.var_type in let%bind t = compile_type_expression x.var_type in
let%bind expression = abstr_expression x.init in let%bind expression = compile_expression x.init in
return_let_in ~loc (Var.of_name name, Some t) false false expression return_let_in ~loc (Var.of_name name, Some t) false false expression
| LocalConst x -> | LocalConst x ->
let (x , loc) = r_split x in let (x , loc) = r_split x in
let name = x.name.value in let name = x.name.value in
let%bind t = abstr_type_expression x.const_type in let%bind t = compile_type_expression x.const_type in
let%bind expression = abstr_expression x.init in let%bind expression = compile_expression x.init in
let inline = let inline =
match x.attributes with match x.attributes with
None -> false None -> false
@ -630,7 +630,7 @@ and abstr_data_declaration : Raw.data_decl -> _ result =
in return_let_in ~loc (Var.of_name name, Some t) false inline expression in return_let_in ~loc (Var.of_name name, Some t) false inline expression
| LocalFun f -> | LocalFun f ->
let (f , loc) = r_split f in let (f , loc) = r_split f in
let%bind (binder, expr) = abstr_fun_decl ~loc f in let%bind (binder, expr) = compile_fun_decl ~loc f in
let inline = let inline =
match f.attributes with match f.attributes with
None -> false None -> false
@ -639,22 +639,22 @@ and abstr_data_declaration : Raw.data_decl -> _ result =
|> List.exists (fun Region.{value; _} -> value = "\"inline\"") |> List.exists (fun Region.{value; _} -> value = "\"inline\"")
in return_let_in ~loc binder false inline expr in return_let_in ~loc binder false inline expr
and abstr_param : and compile_param :
Raw.param_decl -> (string * type_expression) result = Raw.param_decl -> (string * type_expression) result =
fun t -> fun t ->
match t with match t with
| ParamConst c -> | ParamConst c ->
let c = c.value in let c = c.value in
let param_name = c.var.value in let param_name = c.var.value in
let%bind type_expression = abstr_type_expression c.param_type in let%bind type_expression = compile_type_expression c.param_type in
ok (param_name , type_expression) ok (param_name , type_expression)
| ParamVar v -> | ParamVar v ->
let c = v.value in let c = v.value in
let param_name = c.var.value in let param_name = c.var.value in
let%bind type_expression = abstr_type_expression c.param_type in let%bind type_expression = compile_type_expression c.param_type in
ok (param_name , type_expression) ok (param_name , type_expression)
and abstr_fun_decl : and compile_fun_decl :
loc:_ -> Raw.fun_decl -> loc:_ -> Raw.fun_decl ->
((expression_variable * type_expression option) * expression) result = ((expression_variable * type_expression option) * expression) result =
fun ~loc x -> fun ~loc x ->
@ -674,11 +674,11 @@ and abstr_fun_decl :
in in
(match param.value.inside with (match param.value.inside with
a, [] -> ( a, [] -> (
let%bind input = abstr_param a in let%bind input = compile_param a in
let (binder , input_type) = input in let (binder , input_type) = input in
let%bind instructions = abstr_statement_list statements in let%bind instructions = compile_statement_list statements in
let%bind result = abstr_expression return in let%bind result = compile_expression return in
let%bind output_type = abstr_type_expression ret_type in let%bind output_type = compile_type_expression ret_type in
let body = instructions in let body = instructions in
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
@ -699,7 +699,7 @@ and abstr_fun_decl :
let lst = npseq_to_list lst in let lst = npseq_to_list lst in
(* TODO wrong, should be fresh? *) (* TODO wrong, should be fresh? *)
let arguments_name = Var.of_name "arguments" in let arguments_name = Var.of_name "arguments" in
let%bind params = bind_map_list abstr_param lst in let%bind params = bind_map_list compile_param lst in
let (binder , input_type) = let (binder , input_type) =
let type_expression = t_tuple (List.map snd params) in let type_expression = t_tuple (List.map snd params) in
(arguments_name , type_expression) in (arguments_name , type_expression) in
@ -712,9 +712,9 @@ and abstr_fun_decl :
ass ass
in in
bind_list @@ List.mapi aux params in bind_list @@ List.mapi aux params in
let%bind instructions = abstr_statement_list statements in let%bind instructions = compile_statement_list statements in
let%bind result = abstr_expression return in let%bind result = compile_expression return in
let%bind output_type = abstr_type_expression ret_type in let%bind output_type = compile_type_expression ret_type in
let body = tpl_declarations @ instructions in let body = tpl_declarations @ instructions in
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
@ -732,7 +732,7 @@ and abstr_fun_decl :
) )
) )
and abstr_fun_expression : and compile_fun_expression :
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result = loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
fun ~loc x -> fun ~loc x ->
let open! Raw in let open! Raw in
@ -740,11 +740,11 @@ and abstr_fun_expression :
let statements = [] in let statements = [] in
(match param.value.inside with (match param.value.inside with
a, [] -> ( a, [] -> (
let%bind input = abstr_param a in let%bind input = compile_param a in
let (binder , input_type) = input in let (binder , input_type) = input in
let%bind instructions = abstr_statement_list statements in let%bind instructions = compile_statement_list statements in
let%bind result = abstr_expression return in let%bind result = compile_expression return in
let%bind output_type = abstr_type_expression ret_type in let%bind output_type = compile_type_expression ret_type in
let body = instructions in let body = instructions in
let%bind result = let%bind result =
@ -763,7 +763,7 @@ and abstr_fun_expression :
let lst = npseq_to_list lst in let lst = npseq_to_list lst in
(* TODO wrong, should be fresh? *) (* TODO wrong, should be fresh? *)
let arguments_name = Var.of_name "arguments" in let arguments_name = Var.of_name "arguments" in
let%bind params = bind_map_list abstr_param lst in let%bind params = bind_map_list compile_param lst in
let (binder , input_type) = let (binder , input_type) =
let type_expression = t_tuple (List.map snd params) in let type_expression = t_tuple (List.map snd params) in
(arguments_name , type_expression) in (arguments_name , type_expression) in
@ -775,9 +775,9 @@ and abstr_fun_expression :
ass ass
in in
bind_list @@ List.mapi aux params in bind_list @@ List.mapi aux params in
let%bind instructions = abstr_statement_list statements in let%bind instructions = compile_statement_list statements in
let%bind result = abstr_expression return in let%bind result = compile_expression return in
let%bind output_type = abstr_type_expression ret_type in let%bind output_type = compile_type_expression ret_type in
let body = tpl_declarations @ instructions in let body = tpl_declarations @ instructions in
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
@ -792,7 +792,7 @@ and abstr_fun_expression :
) )
) )
and abstr_statement_list statements = and compile_statement_list statements =
let open Raw in let open Raw in
let rec hook acc = function let rec hook acc = function
[] -> acc [] -> acc
@ -814,9 +814,9 @@ and abstr_statement_list statements =
(* Detached attributes are erased. TODO: Warning. *) (* Detached attributes are erased. TODO: Warning. *)
hook acc statements hook acc statements
| Instr i :: statements -> | Instr i :: statements ->
hook (abstr_instruction i :: acc) statements hook (compile_instruction i :: acc) statements
| Data d :: statements -> | Data d :: statements ->
hook (abstr_data_declaration d :: acc) statements hook (compile_data_declaration d :: acc) statements
in bind_list @@ hook [] (List.rev statements) in bind_list @@ hook [] (List.rev statements)
and get_case_variables (t:Raw.pattern) : expression_variable list result = and get_case_variables (t:Raw.pattern) : expression_variable list result =
@ -848,7 +848,7 @@ and get_case_variables (t:Raw.pattern) : expression_variable list result =
| PVar v -> ok @@ [Var.of_name v.value] | PVar v -> ok @@ [Var.of_name v.value]
| p -> fail @@ unsupported_cst_constr p | p -> fail @@ unsupported_cst_constr p
and abstr_single_instruction : Raw.instruction -> (_ -> expression result) result = and compile_single_instruction : Raw.instruction -> (_ -> expression result) result =
fun t -> fun t ->
match t with match t with
| ProcCall x -> ( | ProcCall x -> (
@ -860,15 +860,15 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
let (f_name , f_loc) = r_split name in let (f_name , f_loc) = r_split name in
match constants f_name with match constants f_name with
| Error _ -> | Error _ ->
let%bind arg = abstr_tuple_expression ~loc:args_loc args' in let%bind arg = compile_tuple_expression ~loc:args_loc args' in
return_statement @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg return_statement @@ e_application ~loc (e_variable ~loc:f_loc (Var.of_name f_name)) arg
| Ok (s,_) -> | Ok (s,_) ->
let%bind lst = bind_map_list abstr_expression args' in let%bind lst = bind_map_list compile_expression args' in
return_statement @@ e_constant ~loc s lst return_statement @@ e_constant ~loc s lst
) )
| f -> ( | f -> (
let%bind f' = abstr_expression f in let%bind f' = compile_expression f in
let%bind arg = abstr_tuple_expression ~loc:args_loc args' in let%bind arg = compile_tuple_expression ~loc:args_loc args' in
return_statement @@ e_application ~loc f' arg return_statement @@ e_application ~loc f' arg
) )
) )
@ -877,35 +877,35 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
return_statement @@ e_skip ~loc () return_statement @@ e_skip ~loc ()
) )
| Loop (While l) -> | Loop (While l) ->
abstr_while_loop l.value compile_while_loop l.value
| Loop (For (ForInt fi)) -> ( | Loop (For (ForInt fi)) -> (
let%bind loop = abstr_for_int fi.value in let%bind loop = compile_for_int fi.value in
ok loop ok loop
) )
| Loop (For (ForCollect fc)) -> | Loop (For (ForCollect fc)) ->
let%bind loop = abstr_for_collect fc.value in let%bind loop = compile_for_collect fc.value in
ok loop ok loop
| Cond c -> ( | Cond c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = abstr_expression c.test in let%bind expr = compile_expression c.test in
let%bind match_true = match c.ifso with let%bind match_true = match c.ifso with
ClauseInstr i -> ClauseInstr i ->
abstr_single_instruction i compile_single_instruction i
| ClauseBlock b -> | ClauseBlock b ->
match b with match b with
LongBlock {value; _} -> LongBlock {value; _} ->
abstr_block value compile_block value
| ShortBlock {value; _} -> | ShortBlock {value; _} ->
abstr_statements @@ fst value.inside in compile_statements @@ fst value.inside in
let%bind match_false = match c.ifnot with let%bind match_false = match c.ifnot with
ClauseInstr i -> ClauseInstr i ->
abstr_single_instruction i compile_single_instruction i
| ClauseBlock b -> | ClauseBlock b ->
match b with match b with
LongBlock {value; _} -> LongBlock {value; _} ->
abstr_block value compile_block value
| ShortBlock {value; _} -> | ShortBlock {value; _} ->
abstr_statements @@ fst value.inside in compile_statements @@ fst value.inside in
let env = Var.fresh () in let env = Var.fresh () in
let%bind match_true' = match_true None in let%bind match_true' = match_true None in
@ -929,10 +929,10 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
) )
| Assign a -> ( | Assign a -> (
let (a , loc) = r_split a in let (a , loc) = r_split a in
let%bind value_expr = abstr_expression a.rhs in let%bind value_expr = compile_expression a.rhs in
match a.lhs with match a.lhs with
| Path path -> ( | Path path -> (
let (name , path') = abstr_path path in let (name , path') = compile_path path in
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in
return_let_in let_binder mut inline rhs return_let_in let_binder mut inline rhs
) )
@ -941,11 +941,11 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
let%bind (varname,map,path) = match v'.path with let%bind (varname,map,path) = match v'.path with
| Name name -> ok (name.value , e_variable (Var.of_name name.value), []) | Name name -> ok (name.value , e_variable (Var.of_name name.value), [])
| Path p -> | Path p ->
let (name,p') = abstr_path v'.path in let (name,p') = compile_path v'.path in
let%bind accessor = abstr_projection p in let%bind accessor = compile_projection p in
ok @@ (name , accessor , p') ok @@ (name , accessor , p')
in in
let%bind key_expr = abstr_expression v'.index.value.inside in let%bind key_expr = compile_expression v'.index.value.inside in
let expr' = e_map_add key_expr value_expr map in let expr' = e_map_add key_expr value_expr map in
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in
return_let_in let_binder mut inline rhs return_let_in let_binder mut inline rhs
@ -953,20 +953,20 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
) )
| CaseInstr c -> ( | CaseInstr c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = abstr_expression c.expr in let%bind expr = compile_expression c.expr in
let env = Var.fresh () in let env = Var.fresh () in
let%bind (fv,cases) = let%bind (fv,cases) =
let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) = let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) =
let%bind case_clause = let%bind case_clause =
match x.value.rhs with match x.value.rhs with
ClauseInstr i -> ClauseInstr i ->
abstr_single_instruction i compile_single_instruction i
| ClauseBlock b -> | ClauseBlock b ->
match b with match b with
LongBlock {value; _} -> LongBlock {value; _} ->
abstr_block value compile_block value
| ShortBlock {value; _} -> | ShortBlock {value; _} ->
abstr_statements @@ fst value.inside in compile_statements @@ fst value.inside in
let%bind case_clause'= case_clause @@ None in let%bind case_clause'= case_clause @@ None in
let%bind case_clause = case_clause @@ Some(e_variable env) in let%bind case_clause = case_clause @@ Some(e_variable env) in
let%bind case_vars = get_case_variables x.value.pattern in let%bind case_vars = get_case_variables x.value.pattern in
@ -976,11 +976,11 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
let free_vars = List.concat fv in let free_vars = List.concat fv in
if (List.length free_vars == 0) then ( if (List.length free_vars == 0) then (
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
let%bind m = abstr_cases cases in let%bind m = compile_cases cases in
return_statement @@ e_matching ~loc expr m return_statement @@ e_matching ~loc expr m
) else ( ) else (
let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
let%bind m = abstr_cases cases in let%bind m = compile_cases cases in
let match_expr = e_matching ~loc expr m in let match_expr = e_matching ~loc expr m in
let return_expr = fun expr -> let return_expr = fun expr ->
e_let_in (env,None) false false (store_mutable_variable free_vars) @@ e_let_in (env,None) false false (store_mutable_variable free_vars) @@
@ -1002,8 +1002,8 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
region=r.record_inj.region region=r.record_inj.region
} in } in
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
let%bind expr = abstr_update {value=u;region=reg} in let%bind expr = compile_update {value=u;region=reg} in
let (name , access_path) = abstr_path r.path in let (name , access_path) = compile_path r.path in
let loc = Some loc in let loc = Some loc in
let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in
return_let_in binder mut inline rhs return_let_in binder mut inline rhs
@ -1011,13 +1011,13 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
) )
| MapPatch patch -> ( | MapPatch patch -> (
let (map_p, loc) = r_split patch in let (map_p, loc) = r_split patch in
let (name, access_path) = abstr_path map_p.path in let (name, access_path) = compile_path map_p.path in
let%bind inj = bind_list let%bind inj = bind_list
@@ List.map (fun (x:Raw.binding Region.reg) -> @@ List.map (fun (x:Raw.binding Region.reg) ->
let x = x.value in let x = x.value in
let (key, value) = x.source, x.image in let (key, value) = x.source, x.image in
let%bind key' = abstr_expression key in let%bind key' = compile_expression key in
let%bind value' = abstr_expression value let%bind value' = compile_expression value
in ok @@ (key', value') in ok @@ (key', value')
) )
@@ npseq_to_list map_p.map_inj.value.ne_elements in @@ npseq_to_list map_p.map_inj.value.ne_elements in
@ -1034,10 +1034,10 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
) )
| SetPatch patch -> ( | SetPatch patch -> (
let (setp, loc) = r_split patch in let (setp, loc) = r_split patch in
let (name , access_path) = abstr_path setp.path in let (name , access_path) = compile_path setp.path in
let%bind inj = let%bind inj =
bind_list @@ bind_list @@
List.map abstr_expression @@ List.map compile_expression @@
npseq_to_list setp.set_inj.value.ne_elements in npseq_to_list setp.set_inj.value.ne_elements in
match inj with match inj with
| [] -> return_statement @@ e_skip ~loc () | [] -> return_statement @@ e_skip ~loc ()
@ -1054,11 +1054,11 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
let%bind (varname,map,path) = match v.map with let%bind (varname,map,path) = match v.map with
| Name v -> ok (v.value , e_variable (Var.of_name v.value) , []) | Name v -> ok (v.value , e_variable (Var.of_name v.value) , [])
| Path p -> | Path p ->
let (name,p') = abstr_path v.map in let (name,p') = compile_path v.map in
let%bind accessor = abstr_projection p in let%bind accessor = compile_projection p in
ok @@ (name , accessor , p') ok @@ (name , accessor , p')
in in
let%bind key' = abstr_expression key in let%bind key' = compile_expression key in
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
return_let_in binder mut inline rhs return_let_in binder mut inline rhs
@ -1068,17 +1068,17 @@ and abstr_single_instruction : Raw.instruction -> (_ -> expression result) resul
let%bind (varname, set, path) = match set_rm.set with let%bind (varname, set, path) = match set_rm.set with
| Name v -> ok (v.value, e_variable (Var.of_name v.value), []) | Name v -> ok (v.value, e_variable (Var.of_name v.value), [])
| Path path -> | Path path ->
let(name, p') = abstr_path set_rm.set in let(name, p') = compile_path set_rm.set in
let%bind accessor = abstr_projection path in let%bind accessor = compile_projection path in
ok @@ (name, accessor, p') ok @@ (name, accessor, p')
in in
let%bind removed' = abstr_expression set_rm.element in let%bind removed' = compile_expression set_rm.element in
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
return_let_in binder mut inline rhs return_let_in binder mut inline rhs
) )
and abstr_path : Raw.path -> string * string list = fun p -> and compile_path : Raw.path -> string * string list = fun p ->
match p with match p with
| Raw.Name v -> (v.value , []) | Raw.Name v -> (v.value , [])
| Raw.Path p -> ( | Raw.Path p -> (
@ -1095,7 +1095,7 @@ and abstr_path : Raw.path -> string * string list = fun p ->
(var , path') (var , path')
) )
and abstr_cases : (Raw.pattern * expression) list -> matching_expr result = fun t -> and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
let open Raw in let open Raw in
let get_var (t:Raw.pattern) = let get_var (t:Raw.pattern) =
match t with match t with
@ -1186,13 +1186,13 @@ and abstr_cases : (Raw.pattern * expression) list -> matching_expr result = fun
bind_map_list aux lst in bind_map_list aux lst in
ok @@ ez_match_variant constrs ok @@ ez_match_variant constrs
and abstr_instruction : Raw.instruction -> (_ -> expression result) result = and compile_instruction : Raw.instruction -> (_ -> expression result) result =
fun t -> trace (abstracting_instruction t) @@ abstr_single_instruction t fun t -> trace (abstracting_instruction t) @@ compile_single_instruction t
and abstr_statements : Raw.statements -> (_ -> expression result) result = and compile_statements : Raw.statements -> (_ -> expression result) result =
fun statements -> fun statements ->
let lst = npseq_to_list statements in let lst = npseq_to_list statements in
let%bind fs = abstr_statement_list lst in let%bind fs = compile_statement_list lst in
let aux : _ -> (expression option -> expression result) -> _ = let aux : _ -> (expression option -> expression result) -> _ =
fun prec cur -> fun prec cur ->
let%bind res = cur prec let%bind res = cur prec
@ -1201,19 +1201,19 @@ and abstr_statements : Raw.statements -> (_ -> expression result) result =
let%bind ret = bind_fold_right_list aux expr' fs in let%bind ret = bind_fold_right_list aux expr' fs in
ok @@ Option.unopt_exn ret ok @@ Option.unopt_exn ret
and abstr_block : Raw.block -> (_ -> expression result) result = and compile_block : Raw.block -> (_ -> expression result) result =
fun t -> abstr_statements t.statements fun t -> compile_statements t.statements
and abstr_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl -> and compile_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl ->
let env_rec = Var.fresh () in let env_rec = Var.fresh () in
let binder = Var.fresh () in let binder = Var.fresh () in
let%bind cond = abstr_expression wl.cond in let%bind cond = compile_expression wl.cond in
let ctrl = let ctrl =
(e_variable binder) (e_variable binder)
in in
let%bind for_body = abstr_block wl.block.value in let%bind for_body = compile_block wl.block.value in
let%bind for_body = for_body @@ Some( ctrl ) in let%bind for_body = for_body @@ Some( ctrl ) in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in
@ -1238,15 +1238,15 @@ and abstr_while_loop : Raw.while_loop -> (_ -> expression result) result = fun w
restore_mutable_variable return_expr captured_name_list env_rec restore_mutable_variable return_expr captured_name_list env_rec
and abstr_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> and compile_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
let env_rec = Var.fresh () in let env_rec = Var.fresh () in
let binder = Var.fresh () in let binder = Var.fresh () in
let name = fi.assign.value.name.value in let name = fi.assign.value.name.value in
let it = Var.of_name name in let it = Var.of_name name in
let var = e_variable it in let var = e_variable it in
(*Make the cond and the step *) (*Make the cond and the step *)
let%bind value = abstr_expression fi.assign.value.expr in let%bind value = compile_expression fi.assign.value.expr in
let%bind bound = abstr_expression fi.bound in let%bind bound = compile_expression fi.bound in
let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in
let step = e_int 1 in let step = e_int 1 in
let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in
@ -1256,7 +1256,7 @@ and abstr_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
continue_expr continue_expr
in in
(* Modify the body loop*) (* Modify the body loop*)
let%bind for_body = abstr_block fi.block.value in let%bind for_body = compile_block fi.block.value in
let%bind for_body = for_body @@ Some ctrl in let%bind for_body = for_body @@ Some ctrl in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder in let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder in
@ -1286,19 +1286,19 @@ and abstr_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
in in
restore_mutable_variable return_expr captured_name_list env_rec restore_mutable_variable return_expr captured_name_list env_rec
and abstr_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> and compile_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc ->
let binder = Var.of_name "arguments" in let binder = Var.of_name "arguments" in
let%bind element_names = ok @@ match fc.bind_to with let%bind element_names = ok @@ match fc.bind_to with
| Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value] | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
| None -> [Var.of_name fc.var.value] in | None -> [Var.of_name fc.var.value] in
let env = Var.fresh () in let env = Var.fresh () in
let%bind for_body = abstr_block fc.block.value in let%bind for_body = compile_block fc.block.value in
let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in
let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in
let init_record = store_mutable_variable free_vars in let init_record = store_mutable_variable free_vars in
let%bind collect = abstr_expression fc.expr in let%bind collect = compile_expression fc.expr in
let aux name expr= let aux name expr=
e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr
in in
@ -1320,7 +1320,7 @@ and abstr_for_collect : Raw.for_collect -> (_ -> expression result) result = fun
in in
restore_mutable_variable fold free_vars env restore_mutable_variable fold free_vars env
and abstr_declaration_list declarations : declaration Location.wrap list result = and compile_declaration_list declarations : declaration Location.wrap list result =
let open Raw in let open Raw in
let rec hook acc = function let rec hook acc = function
[] -> acc [] -> acc
@ -1344,16 +1344,16 @@ and abstr_declaration_list declarations : declaration Location.wrap list result
| TypeDecl decl :: declarations -> | TypeDecl decl :: declarations ->
let decl, loc = r_split decl in let decl, loc = r_split decl in
let {name; type_expr} : Raw.type_decl = decl in let {name; type_expr} : Raw.type_decl = decl in
let%bind type_expression = abstr_type_expression type_expr in let%bind type_expression = compile_type_expression type_expr in
let new_decl = let new_decl =
Declaration_type (Var.of_name name.value, type_expression) in Declaration_type (Var.of_name name.value, type_expression) in
let res = Location.wrap ~loc new_decl in let res = Location.wrap ~loc new_decl in
hook (bind_list_cons res acc) declarations hook (bind_list_cons res acc) declarations
| ConstDecl decl :: declarations -> | ConstDecl decl :: declarations ->
let abstr_const_decl = let compile_const_decl =
fun {name;const_type; init; attributes} -> fun {name;const_type; init; attributes} ->
let%bind expression = abstr_expression init in let%bind expression = compile_expression init in
let%bind t = abstr_type_expression const_type in let%bind t = compile_type_expression const_type in
let type_annotation = Some t in let type_annotation = Some t in
let inline = let inline =
match attributes with match attributes with
@ -1366,11 +1366,11 @@ and abstr_declaration_list declarations : declaration Location.wrap list result
(Var.of_name name.value, type_annotation, inline, expression) (Var.of_name name.value, type_annotation, inline, expression)
in ok new_decl in in ok new_decl in
let%bind res = let%bind res =
bind_map_location abstr_const_decl (Location.lift_region decl) bind_map_location compile_const_decl (Location.lift_region decl)
in hook (bind_list_cons res acc) declarations in hook (bind_list_cons res acc) declarations
| FunDecl fun_decl :: declarations -> | FunDecl fun_decl :: declarations ->
let decl, loc = r_split fun_decl in let decl, loc = r_split fun_decl in
let%bind ((name, ty_opt), expr) = abstr_fun_decl ~loc decl in let%bind ((name, ty_opt), expr) = compile_fun_decl ~loc decl in
let inline = let inline =
match fun_decl.value.attributes with match fun_decl.value.attributes with
None -> false None -> false
@ -1383,5 +1383,5 @@ and abstr_declaration_list declarations : declaration Location.wrap list result
hook (bind_list_cons res acc) declarations hook (bind_list_cons res acc) declarations
in hook (ok @@ []) (List.rev declarations) in hook (ok @@ []) (List.rev declarations)
let abstr_program : Raw.ast -> program result = let compile_program : Raw.ast -> program result =
fun t -> abstr_declaration_list @@ nseq_to_list t.decl fun t -> compile_declaration_list @@ nseq_to_list t.decl

View File

@ -8,8 +8,8 @@ module SMap = Map.String
(** Convert a concrete PascaLIGO expression AST to the imperative (** Convert a concrete PascaLIGO expression AST to the imperative
expression AST used by the compiler. *) expression AST used by the compiler. *)
val abstr_expression : Raw.expr -> expr result val compile_expression : Raw.expr -> expr result
(** Convert a concrete PascaLIGO program AST to the miperative program (** Convert a concrete PascaLIGO program AST to the miperative program
AST used by the compiler. *) AST used by the compiler. *)
val abstr_program : Raw.ast -> program result val compile_program : Raw.ast -> program result

View File

@ -1,6 +1,6 @@
(library (library
(name instruction_remover) (name imperative_to_sugar)
(public_name ligo.instruction_remover) (public_name ligo.imperative_to_sugar)
(libraries (libraries
simple-utils simple-utils
ast_imperative ast_imperative

View File

@ -2,7 +2,7 @@ module I = Ast_imperative
module O = Ast_sugar module O = Ast_sugar
open Trace open Trace
let rec idle_type_expression : I.type_expression -> O.type_expression result = let rec compile_type_expression : I.type_expression -> O.type_expression result =
fun te -> fun te ->
let return te = ok @@ O.make_t te in let return te = ok @@ O.make_t te in
match te.type_content with match te.type_content with
@ -10,7 +10,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
let sum = I.CMap.to_kv_list sum in let sum = I.CMap.to_kv_list sum in
let%bind sum = let%bind sum =
bind_map_list (fun (k,v) -> bind_map_list (fun (k,v) ->
let%bind v = idle_type_expression v in let%bind v = compile_type_expression v in
ok @@ (k,v) ok @@ (k,v)
) sum ) sum
in in
@ -19,168 +19,168 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
let record = I.LMap.to_kv_list record in let record = I.LMap.to_kv_list record in
let%bind record = let%bind record =
bind_map_list (fun (k,v) -> bind_map_list (fun (k,v) ->
let%bind v = idle_type_expression v in let%bind v = compile_type_expression v in
ok @@ (k,v) ok @@ (k,v)
) record ) record
in in
return @@ O.T_record (O.LMap.of_list record) return @@ O.T_record (O.LMap.of_list record)
| I.T_arrow {type1;type2} -> | I.T_arrow {type1;type2} ->
let%bind type1 = idle_type_expression type1 in let%bind type1 = compile_type_expression type1 in
let%bind type2 = idle_type_expression type2 in let%bind type2 = compile_type_expression type2 in
return @@ T_arrow {type1;type2} return @@ T_arrow {type1;type2}
| I.T_variable type_variable -> return @@ T_variable type_variable | I.T_variable type_variable -> return @@ T_variable type_variable
| I.T_constant type_constant -> return @@ T_constant type_constant | I.T_constant type_constant -> return @@ T_constant type_constant
| I.T_operator type_operator -> | I.T_operator type_operator ->
let%bind type_operator = idle_type_operator type_operator in let%bind type_operator = compile_type_operator type_operator in
return @@ T_operator type_operator return @@ T_operator type_operator
and idle_type_operator : I.type_operator -> O.type_operator result = and compile_type_operator : I.type_operator -> O.type_operator result =
fun t_o -> fun t_o ->
match t_o with match t_o with
| TC_contract c -> | TC_contract c ->
let%bind c = idle_type_expression c in let%bind c = compile_type_expression c in
ok @@ O.TC_contract c ok @@ O.TC_contract c
| TC_option o -> | TC_option o ->
let%bind o = idle_type_expression o in let%bind o = compile_type_expression o in
ok @@ O.TC_option o ok @@ O.TC_option o
| TC_list l -> | TC_list l ->
let%bind l = idle_type_expression l in let%bind l = compile_type_expression l in
ok @@ O.TC_list l ok @@ O.TC_list l
| TC_set s -> | TC_set s ->
let%bind s = idle_type_expression s in let%bind s = compile_type_expression s in
ok @@ O.TC_set s ok @@ O.TC_set s
| TC_map (k,v) -> | TC_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_map (k,v) ok @@ O.TC_map (k,v)
| TC_big_map (k,v) -> | TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_big_map (k,v) ok @@ O.TC_big_map (k,v)
| TC_arrow (i,o) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in
ok @@ O.TC_arrow (i,o) ok @@ O.TC_arrow (i,o)
let rec remove_instruction_in_expression : I.expression -> O.expression result = let rec compile_expression : I.expression -> O.expression result =
fun e -> fun e ->
let return expr = ok @@ O.make_expr ~loc:e.location expr in let return expr = ok @@ O.make_expr ~loc:e.location expr in
match e.expression_content with match e.expression_content with
| I.E_literal literal -> return @@ O.E_literal literal | I.E_literal literal -> return @@ O.E_literal literal
| I.E_constant {cons_name;arguments} -> | I.E_constant {cons_name;arguments} ->
let%bind arguments = bind_map_list remove_instruction_in_expression arguments in let%bind arguments = bind_map_list compile_expression arguments in
return @@ O.E_constant {cons_name;arguments} return @@ O.E_constant {cons_name;arguments}
| I.E_variable name -> return @@ O.E_variable name | I.E_variable name -> return @@ O.E_variable name
| I.E_application {expr1;expr2} -> | I.E_application {expr1;expr2} ->
let%bind expr1 = remove_instruction_in_expression expr1 in let%bind expr1 = compile_expression expr1 in
let%bind expr2 = remove_instruction_in_expression expr2 in let%bind expr2 = compile_expression expr2 in
return @@ O.E_application {expr1; expr2} return @@ O.E_application {expr1; expr2}
| I.E_lambda lambda -> | I.E_lambda lambda ->
let%bind lambda = remove_instruction_in_lambda lambda in let%bind lambda = compile_lambda lambda in
return @@ O.E_lambda lambda return @@ O.E_lambda lambda
| I.E_recursive {fun_name;fun_type;lambda} -> | I.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = idle_type_expression fun_type in let%bind fun_type = compile_type_expression fun_type in
let%bind lambda = remove_instruction_in_lambda lambda in let%bind lambda = compile_lambda lambda in
return @@ O.E_recursive {fun_name;fun_type;lambda} return @@ O.E_recursive {fun_name;fun_type;lambda}
| I.E_let_in {let_binder;mut=_;inline;rhs;let_result} -> | I.E_let_in {let_binder;mut=_;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option idle_type_expression ty_opt in let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
let%bind rhs = remove_instruction_in_expression rhs in let%bind rhs = compile_expression rhs in
let%bind let_result = remove_instruction_in_expression let_result in let%bind let_result = compile_expression let_result in
return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| I.E_skip -> return @@ O.E_skip | I.E_skip -> return @@ O.E_skip
| I.E_constructor {constructor;element} -> | I.E_constructor {constructor;element} ->
let%bind element = remove_instruction_in_expression element in let%bind element = compile_expression element in
return @@ O.E_constructor {constructor;element} return @@ O.E_constructor {constructor;element}
| I.E_matching {matchee; cases} -> | I.E_matching {matchee; cases} ->
let%bind matchee = remove_instruction_in_expression matchee in let%bind matchee = compile_expression matchee in
let%bind cases = remove_instruction_in_matching cases in let%bind cases = compile_matching cases in
return @@ O.E_matching {matchee;cases} return @@ O.E_matching {matchee;cases}
| I.E_record record -> | I.E_record record ->
let record = I.LMap.to_kv_list record in let record = I.LMap.to_kv_list record in
let%bind record = let%bind record =
bind_map_list (fun (k,v) -> bind_map_list (fun (k,v) ->
let%bind v =remove_instruction_in_expression v in let%bind v =compile_expression v in
ok @@ (k,v) ok @@ (k,v)
) record ) record
in in
return @@ O.E_record (O.LMap.of_list record) return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {expr;label} -> | I.E_record_accessor {expr;label} ->
let%bind expr = remove_instruction_in_expression expr in let%bind expr = compile_expression expr in
return @@ O.E_record_accessor {expr;label} return @@ O.E_record_accessor {expr;label}
| I.E_record_update {record;path;update} -> | I.E_record_update {record;path;update} ->
let%bind record = remove_instruction_in_expression record in let%bind record = compile_expression record in
let%bind update = remove_instruction_in_expression update in let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update} return @@ O.E_record_update {record;path;update}
| I.E_map map -> | I.E_map map ->
let%bind map = bind_map_list ( let%bind map = bind_map_list (
bind_map_pair remove_instruction_in_expression bind_map_pair compile_expression
) map ) map
in in
return @@ O.E_map map return @@ O.E_map map
| I.E_big_map big_map -> | I.E_big_map big_map ->
let%bind big_map = bind_map_list ( let%bind big_map = bind_map_list (
bind_map_pair remove_instruction_in_expression bind_map_pair compile_expression
) big_map ) big_map
in in
return @@ O.E_big_map big_map return @@ O.E_big_map big_map
| I.E_list lst -> | I.E_list lst ->
let%bind lst = bind_map_list remove_instruction_in_expression lst in let%bind lst = bind_map_list compile_expression lst in
return @@ O.E_list lst return @@ O.E_list lst
| I.E_set set -> | I.E_set set ->
let%bind set = bind_map_list remove_instruction_in_expression set in let%bind set = bind_map_list compile_expression set in
return @@ O.E_set set return @@ O.E_set set
| I.E_look_up look_up -> | I.E_look_up look_up ->
let%bind look_up = bind_map_pair remove_instruction_in_expression look_up in let%bind look_up = bind_map_pair compile_expression look_up in
return @@ O.E_look_up look_up return @@ O.E_look_up look_up
| I.E_ascription {anno_expr; type_annotation} -> | I.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = remove_instruction_in_expression anno_expr in let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = idle_type_expression type_annotation in let%bind type_annotation = compile_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation} return @@ O.E_ascription {anno_expr; type_annotation}
and remove_instruction_in_lambda : I.lambda -> O.lambda result = and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option idle_type_expression input_type in let%bind input_type = bind_map_option compile_type_expression input_type in
let%bind output_type = bind_map_option idle_type_expression output_type in let%bind output_type = bind_map_option compile_type_expression output_type in
let%bind result = remove_instruction_in_expression result in let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result} ok @@ O.{binder;input_type;output_type;result}
and remove_instruction_in_matching : I.matching_expr -> O.matching_expr result = and compile_matching : I.matching_expr -> O.matching_expr result =
fun m -> fun m ->
match m with match m with
| I.Match_bool {match_true;match_false} -> | I.Match_bool {match_true;match_false} ->
let%bind match_true = remove_instruction_in_expression match_true in let%bind match_true = compile_expression match_true in
let%bind match_false = remove_instruction_in_expression match_false in let%bind match_false = compile_expression match_false in
ok @@ O.Match_bool {match_true;match_false} ok @@ O.Match_bool {match_true;match_false}
| I.Match_list {match_nil;match_cons} -> | I.Match_list {match_nil;match_cons} ->
let%bind match_nil = remove_instruction_in_expression match_nil in let%bind match_nil = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in let (hd,tl,expr,tv) = match_cons in
let%bind expr = remove_instruction_in_expression expr in let%bind expr = compile_expression expr in
ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
| I.Match_option {match_none;match_some} -> | I.Match_option {match_none;match_some} ->
let%bind match_none = remove_instruction_in_expression match_none in let%bind match_none = compile_expression match_none in
let (n,expr,tv) = match_some in let (n,expr,tv) = match_some in
let%bind expr = remove_instruction_in_expression expr in let%bind expr = compile_expression expr in
ok @@ O.Match_option {match_none; match_some=(n,expr,tv)} ok @@ O.Match_option {match_none; match_some=(n,expr,tv)}
| I.Match_tuple ((lst,expr), tv) -> | I.Match_tuple ((lst,expr), tv) ->
let%bind expr = remove_instruction_in_expression expr in let%bind expr = compile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv) ok @@ O.Match_tuple ((lst,expr), tv)
| I.Match_variant (lst,tv) -> | I.Match_variant (lst,tv) ->
let%bind lst = bind_map_list ( let%bind lst = bind_map_list (
fun ((c,n),expr) -> fun ((c,n),expr) ->
let%bind expr = remove_instruction_in_expression expr in let%bind expr = compile_expression expr in
ok @@ ((c,n),expr) ok @@ ((c,n),expr)
) lst ) lst
in in
ok @@ O.Match_variant (lst,tv) ok @@ O.Match_variant (lst,tv)
let remove_instruction_in_declaration : I.declaration Location.wrap -> _ = let compile_declaration : I.declaration Location.wrap -> _ =
fun {wrap_content=declaration;location} -> fun {wrap_content=declaration;location} ->
let return decl = ok @@ Location.wrap ~loc:location decl in let return decl = ok @@ Location.wrap ~loc:location decl in
match declaration with match declaration with
| I.Declaration_constant (n, te_opt, inline, expr) -> | I.Declaration_constant (n, te_opt, inline, expr) ->
let%bind expr = remove_instruction_in_expression expr in let%bind expr = compile_expression expr in
let%bind te_opt = bind_map_option idle_type_expression te_opt in let%bind te_opt = bind_map_option compile_type_expression te_opt in
return @@ O.Declaration_constant (n, te_opt, inline, expr) return @@ O.Declaration_constant (n, te_opt, inline, expr)
| I.Declaration_type (n, te) -> | I.Declaration_type (n, te) ->
let%bind te = idle_type_expression te in let%bind te = compile_type_expression te in
return @@ O.Declaration_type (n,te) return @@ O.Declaration_type (n,te)
let remove_instruction_in_program : I.program -> O.program result = let compile_program : I.program -> O.program result =
fun p -> fun p ->
bind_map_list remove_instruction_in_declaration p bind_map_list compile_declaration p

View File

@ -1,6 +1,6 @@
(library (library
(name simplifier) (name sugar_to_core)
(public_name ligo.simplifier) (public_name ligo.sugar_to_core)
(libraries (libraries
simple-utils simple-utils
ast_sugar ast_sugar

View File

@ -59,129 +59,129 @@ and idle_type_operator : I.type_operator -> O.type_operator result =
let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in
ok @@ O.TC_arrow (i,o) ok @@ O.TC_arrow (i,o)
let rec simplify_expression : I.expression -> O.expression result = let rec compile_expression : I.expression -> O.expression result =
fun e -> fun e ->
let return expr = ok @@ O.make_expr ~loc:e.location expr in let return expr = ok @@ O.make_expr ~loc:e.location expr in
match e.expression_content with match e.expression_content with
| I.E_literal literal -> return @@ O.E_literal literal | I.E_literal literal -> return @@ O.E_literal literal
| I.E_constant {cons_name;arguments} -> | I.E_constant {cons_name;arguments} ->
let%bind arguments = bind_map_list simplify_expression arguments in let%bind arguments = bind_map_list compile_expression arguments in
return @@ O.E_constant {cons_name;arguments} return @@ O.E_constant {cons_name;arguments}
| I.E_variable name -> return @@ O.E_variable name | I.E_variable name -> return @@ O.E_variable name
| I.E_application {expr1;expr2} -> | I.E_application {expr1;expr2} ->
let%bind expr1 = simplify_expression expr1 in let%bind expr1 = compile_expression expr1 in
let%bind expr2 = simplify_expression expr2 in let%bind expr2 = compile_expression expr2 in
return @@ O.E_application {expr1; expr2} return @@ O.E_application {expr1; expr2}
| I.E_lambda lambda -> | I.E_lambda lambda ->
let%bind lambda = simplify_lambda lambda in let%bind lambda = compile_lambda lambda in
return @@ O.E_lambda lambda return @@ O.E_lambda lambda
| I.E_recursive {fun_name;fun_type;lambda} -> | I.E_recursive {fun_name;fun_type;lambda} ->
let%bind fun_type = idle_type_expression fun_type in let%bind fun_type = idle_type_expression fun_type in
let%bind lambda = simplify_lambda lambda in let%bind lambda = compile_lambda lambda in
return @@ O.E_recursive {fun_name;fun_type;lambda} return @@ O.E_recursive {fun_name;fun_type;lambda}
| I.E_let_in {let_binder;inline;rhs;let_result} -> | I.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option idle_type_expression ty_opt in let%bind ty_opt = bind_map_option idle_type_expression ty_opt in
let%bind rhs = simplify_expression rhs in let%bind rhs = compile_expression rhs in
let%bind let_result = simplify_expression let_result in let%bind let_result = compile_expression let_result in
return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result} return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| I.E_skip -> return @@ O.E_skip | I.E_skip -> return @@ O.E_skip
| I.E_constructor {constructor;element} -> | I.E_constructor {constructor;element} ->
let%bind element = simplify_expression element in let%bind element = compile_expression element in
return @@ O.E_constructor {constructor;element} return @@ O.E_constructor {constructor;element}
| I.E_matching {matchee; cases} -> | I.E_matching {matchee; cases} ->
let%bind matchee = simplify_expression matchee in let%bind matchee = compile_expression matchee in
let%bind cases = simplify_matching cases in let%bind cases = compile_matching cases in
return @@ O.E_matching {matchee;cases} return @@ O.E_matching {matchee;cases}
| I.E_record record -> | I.E_record record ->
let record = I.LMap.to_kv_list record in let record = I.LMap.to_kv_list record in
let%bind record = let%bind record =
bind_map_list (fun (k,v) -> bind_map_list (fun (k,v) ->
let%bind v =simplify_expression v in let%bind v =compile_expression v in
ok @@ (k,v) ok @@ (k,v)
) record ) record
in in
return @@ O.E_record (O.LMap.of_list record) return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {expr;label} -> | I.E_record_accessor {expr;label} ->
let%bind expr = simplify_expression expr in let%bind expr = compile_expression expr in
return @@ O.E_record_accessor {expr;label} return @@ O.E_record_accessor {expr;label}
| I.E_record_update {record;path;update} -> | I.E_record_update {record;path;update} ->
let%bind record = simplify_expression record in let%bind record = compile_expression record in
let%bind update = simplify_expression update in let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update} return @@ O.E_record_update {record;path;update}
| I.E_map map -> | I.E_map map ->
let%bind map = bind_map_list ( let%bind map = bind_map_list (
bind_map_pair simplify_expression bind_map_pair compile_expression
) map ) map
in in
return @@ O.E_map map return @@ O.E_map map
| I.E_big_map big_map -> | I.E_big_map big_map ->
let%bind big_map = bind_map_list ( let%bind big_map = bind_map_list (
bind_map_pair simplify_expression bind_map_pair compile_expression
) big_map ) big_map
in in
return @@ O.E_big_map big_map return @@ O.E_big_map big_map
| I.E_list lst -> | I.E_list lst ->
let%bind lst = bind_map_list simplify_expression lst in let%bind lst = bind_map_list compile_expression lst in
return @@ O.E_list lst return @@ O.E_list lst
| I.E_set set -> | I.E_set set ->
let%bind set = bind_map_list simplify_expression set in let%bind set = bind_map_list compile_expression set in
return @@ O.E_set set return @@ O.E_set set
| I.E_look_up look_up -> | I.E_look_up look_up ->
let%bind look_up = bind_map_pair simplify_expression look_up in let%bind look_up = bind_map_pair compile_expression look_up in
return @@ O.E_look_up look_up return @@ O.E_look_up look_up
| I.E_ascription {anno_expr; type_annotation} -> | I.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = simplify_expression anno_expr in let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = idle_type_expression type_annotation in let%bind type_annotation = idle_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation} return @@ O.E_ascription {anno_expr; type_annotation}
and simplify_lambda : I.lambda -> O.lambda result = and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option idle_type_expression input_type in let%bind input_type = bind_map_option idle_type_expression input_type in
let%bind output_type = bind_map_option idle_type_expression output_type in let%bind output_type = bind_map_option idle_type_expression output_type in
let%bind result = simplify_expression result in let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result} ok @@ O.{binder;input_type;output_type;result}
and simplify_matching : I.matching_expr -> O.matching_expr result = and compile_matching : I.matching_expr -> O.matching_expr result =
fun m -> fun m ->
match m with match m with
| I.Match_bool {match_true;match_false} -> | I.Match_bool {match_true;match_false} ->
let%bind match_true = simplify_expression match_true in let%bind match_true = compile_expression match_true in
let%bind match_false = simplify_expression match_false in let%bind match_false = compile_expression match_false in
ok @@ O.Match_bool {match_true;match_false} ok @@ O.Match_bool {match_true;match_false}
| I.Match_list {match_nil;match_cons} -> | I.Match_list {match_nil;match_cons} ->
let%bind match_nil = simplify_expression match_nil in let%bind match_nil = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in let (hd,tl,expr,tv) = match_cons in
let%bind expr = simplify_expression expr in let%bind expr = compile_expression expr in
ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
| I.Match_option {match_none;match_some} -> | I.Match_option {match_none;match_some} ->
let%bind match_none = simplify_expression match_none in let%bind match_none = compile_expression match_none in
let (n,expr,tv) = match_some in let (n,expr,tv) = match_some in
let%bind expr = simplify_expression expr in let%bind expr = compile_expression expr in
ok @@ O.Match_option {match_none; match_some=(n,expr,tv)} ok @@ O.Match_option {match_none; match_some=(n,expr,tv)}
| I.Match_tuple ((lst,expr), tv) -> | I.Match_tuple ((lst,expr), tv) ->
let%bind expr = simplify_expression expr in let%bind expr = compile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv) ok @@ O.Match_tuple ((lst,expr), tv)
| I.Match_variant (lst,tv) -> | I.Match_variant (lst,tv) ->
let%bind lst = bind_map_list ( let%bind lst = bind_map_list (
fun ((c,n),expr) -> fun ((c,n),expr) ->
let%bind expr = simplify_expression expr in let%bind expr = compile_expression expr in
ok @@ ((c,n),expr) ok @@ ((c,n),expr)
) lst ) lst
in in
ok @@ O.Match_variant (lst,tv) ok @@ O.Match_variant (lst,tv)
let simplify_declaration : I.declaration Location.wrap -> _ = let compile_declaration : I.declaration Location.wrap -> _ =
fun {wrap_content=declaration;location} -> fun {wrap_content=declaration;location} ->
let return decl = ok @@ Location.wrap ~loc:location decl in let return decl = ok @@ Location.wrap ~loc:location decl in
match declaration with match declaration with
| I.Declaration_constant (n, te_opt, inline, expr) -> | I.Declaration_constant (n, te_opt, inline, expr) ->
let%bind expr = simplify_expression expr in let%bind expr = compile_expression expr in
let%bind te_opt = bind_map_option idle_type_expression te_opt in let%bind te_opt = bind_map_option idle_type_expression te_opt in
return @@ O.Declaration_constant (n, te_opt, inline, expr) return @@ O.Declaration_constant (n, te_opt, inline, expr)
| I.Declaration_type (n, te) -> | I.Declaration_type (n, te) ->
let%bind te = idle_type_expression te in let%bind te = idle_type_expression te in
return @@ O.Declaration_type (n,te) return @@ O.Declaration_type (n,te)
let simplify_program : I.program -> O.program result = let compile_program : I.program -> O.program result =
fun p -> fun p ->
bind_map_list simplify_declaration p bind_map_list compile_declaration p

View File

@ -9,7 +9,7 @@ open Trace
a new constructor at all those places. a new constructor at all those places.
*) *)
module Abstracter = struct module Concrete_to_imperative = struct
open Ast_imperative open Ast_imperative
(* (*

View File

@ -1,5 +1,5 @@
module Abstracter : sig module Concrete_to_imperative : sig
open Ast_imperative open Ast_imperative
open Trace open Trace