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

Added back return instead of ok.

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-06-22 16:29:32 +02:00
parent 8f4ed11539
commit 94039c4d65
1 changed files with 97 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
src/passes/02-concrete_to_imperative/pascaligo.ml
View File

@ -16,8 +16,9 @@ open Operators.Concrete_to_imperative.Pascaligo
let r_split = Location.r_split let r_split = Location.r_split
let return = ok
let rec compile_type_expression : CST.type_expr -> _ result = fun te -> let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
let return te = ok @@ te in
match te with match te with
TSum sum -> TSum sum ->
let (nsepseq, loc) = r_split sum in let (nsepseq, loc) = r_split sum in
@ -36,7 +37,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
let aux (field : CST.field_decl CST.reg) = let aux (field : CST.field_decl CST.reg) =
let (f, _) = r_split field in let (f, _) = r_split field in
let%bind type_expr = compile_type_expression f.field_type in let%bind type_expr = compile_type_expression f.field_type in
ok @@ (f.field_name.value,type_expr) return @@ (f.field_name.value,type_expr)
in in
let%bind record = bind_map_list aux lst in let%bind record = bind_map_list aux lst in
return @@ t_record_ez ~loc record return @@ t_record_ez ~loc record
@ -66,7 +67,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
get_t_string_singleton_opt d in get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in let%bind c' = compile_type_expression c in
ok @@ t_michelson_or ~loc a' b' c' d' return @@ t_michelson_or ~loc a' b' c' d'
) )
| _ -> fail @@ michelson_type_wrong_arity loc operator.value) | _ -> fail @@ michelson_type_wrong_arity loc operator.value)
| "michelson_pair" -> | "michelson_pair" ->
@ -81,7 +82,7 @@ let rec compile_type_expression : CST.type_expr -> _ result = fun te ->
get_t_string_singleton_opt d in get_t_string_singleton_opt d in
let%bind a' = compile_type_expression a in let%bind a' = compile_type_expression a in
let%bind c' = compile_type_expression c in let%bind c' = compile_type_expression c in
ok @@ t_michelson_pair ~loc a' b' c' d' return @@ t_michelson_pair ~loc a' b' c' d'
) )
| _ -> fail @@ michelson_type_wrong_arity loc operator.value) | _ -> fail @@ michelson_type_wrong_arity loc operator.value)
| _ -> | _ ->
@ -119,12 +120,11 @@ let compile_selection (selection : CST.selection) =
(Access_tuple index, loc) (Access_tuple index, loc)
let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error) result = fun e -> let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error) result = fun e ->
let return e = ok @@ e in
let compile_tuple_expression (tuple_expr : CST.tuple_expr) = let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in let (lst, loc) = r_split tuple_expr in
let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in
match lst with match lst with
hd::[] -> return @@ hd hd::[] -> return hd
| lst -> return @@ e_tuple ~loc lst | lst -> return @@ e_tuple ~loc lst
in in
let compile_path (path : CST.path) = let compile_path (path : CST.path) =
@ -245,7 +245,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (fa, _) = r_split fa in let (fa, _) = r_split fa in
let (name, _) = r_split fa.field_name in let (name, _) = r_split fa.field_name in
let%bind expr = compile_expression fa.field_expr in let%bind expr = compile_expression fa.field_expr in
ok @@ (name, expr) return (name, expr)
in in
let%bind record = bind_map_list aux @@ npseq_to_list record.ne_elements in let%bind record = bind_map_list aux @@ npseq_to_list record.ne_elements in
return @@ e_record_ez ~loc record return @@ e_record_ez ~loc record
@ -271,7 +271,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
(Access_record proj.struct_name.value)::path (Access_record proj.struct_name.value)::path
) )
in in
ok @@ (path, expr, loc) return (path, expr, loc)
in in
let%bind updates = bind_map_list aux @@ npseq_to_list updates.ne_elements in let%bind updates = bind_map_list aux @@ npseq_to_list updates.ne_elements in
let aux e (path, update, loc) = e_update ~loc e path update in let aux e (path, update, loc) = e_update ~loc e path update in
@ -283,12 +283,12 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (p, _) = r_split p in let (p, _) = r_split p in
let (var, _loc) = r_split p.var in let (var, _loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in
ok @@ (var, p_type) return (var, p_type)
| ParamVar p -> | ParamVar p ->
let (p, _) = r_split p in let (p, _) = r_split p in
let (var, _loc) = r_split p.var in let (var, _loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in
ok @@ (var, p_type) return (var, p_type)
in in
let (func, loc) = r_split func in let (func, loc) = r_split func in
let (param, loc_par) = r_split func.param in let (param, loc_par) = r_split func.param in
@ -394,7 +394,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (binding, _) = r_split binding in let (binding, _) = r_split binding in
let%bind key = compile_expression binding.source in let%bind key = compile_expression binding.source in
let%bind value = compile_expression binding.image in let%bind value = compile_expression binding.image in
ok @@ (key,value) return (key,value)
in in
let%bind map = bind_map_list aux lst in let%bind map = bind_map_list aux lst in
return @@ e_map ~loc map return @@ e_map ~loc map
@ -406,7 +406,7 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
let (binding, _) = r_split binding in let (binding, _) = r_split binding in
let%bind key = compile_expression binding.source in let%bind key = compile_expression binding.source in
let%bind value = compile_expression binding.image in let%bind value = compile_expression binding.image in
ok @@ (key,value) return (key,value)
in in
let%bind map = bind_map_list aux lst in let%bind map = bind_map_list aux lst in
return @@ e_big_map ~loc map return @@ e_big_map ~loc map
@ -420,14 +420,12 @@ let rec compile_expression : CST.expr -> (AST.expr , Errors_pascaligo.abs_error)
and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ = and compile_matching_expr : type a.(a -> _ result) -> a CST.case_clause CST.reg List.Ne.t -> _ =
fun compiler cases -> fun compiler cases ->
let compile_pattern pattern = ok @@ pattern let compile_pattern pattern = return pattern in
in
let return e = ok @@ e in
let compile_simple_pattern (pattern : CST.pattern) = let compile_simple_pattern (pattern : CST.pattern) =
match pattern with match pattern with
PVar var -> PVar var ->
let (var, _) = r_split var in let (var, _) = r_split var in
ok @@ Var.of_name var return @@ Var.of_name var
| _ -> fail @@ unsupported_non_var_pattern pattern | _ -> fail @@ unsupported_non_var_pattern pattern
in in
let compile_list_pattern (cases : (CST.pattern * _) list) = let compile_list_pattern (cases : (CST.pattern * _) list) =
@ -436,12 +434,12 @@ fun compiler cases ->
| [(PList PCons cons, econs);(PList PNil _, match_nil)] -> | [(PList PCons cons, econs);(PList PNil _, match_nil)] ->
let (cons,_) = r_split cons in let (cons,_) = r_split cons in
let%bind (hd,tl) = match snd @@ List.split (snd cons) with let%bind (hd,tl) = match snd @@ List.split (snd cons) with
tl::[] -> ok @@ (fst cons,tl) tl::[] -> return (fst cons,tl)
| _ -> fail @@ unsupported_deep_list_patterns @@ fst cons | _ -> fail @@ unsupported_deep_list_patterns @@ fst cons
in in
let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in
let match_cons = (hd,tl,econs) in let match_cons = (hd,tl,econs) in
ok @@ (match_nil,match_cons) return (match_nil,match_cons)
| _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases | _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases
in in
let compile_simple_tuple_pattern (tuple : CST.tuple_pattern) = let compile_simple_tuple_pattern (tuple : CST.tuple_pattern) =
@ -456,22 +454,22 @@ fun compiler cases ->
( match c with ( match c with
PUnit _ -> PUnit _ ->
fail @@ unsupported_pattern_type constr fail @@ unsupported_pattern_type constr
| PFalse _ -> ok @@ (Constructor "false", Var.of_name "_") | PFalse _ -> return (Constructor "false", Var.of_name "_")
| PTrue _ -> ok @@ (Constructor "true", Var.of_name "_") | PTrue _ -> return (Constructor "true", Var.of_name "_")
| PNone _ -> ok @@ (Constructor "None", Var.of_name "_") | PNone _ -> return (Constructor "None", Var.of_name "_")
| PSomeApp some -> | PSomeApp some ->
let (some,_) = r_split some in let (some,_) = r_split some in
let (_, pattern) = some in let (_, pattern) = some in
let (pattern,_) = r_split pattern in let (pattern,_) = r_split pattern in
let%bind pattern = compile_simple_pattern pattern.inside in let%bind pattern = compile_simple_pattern pattern.inside in
ok @@ (Constructor "Some", pattern) return (Constructor "Some", pattern)
| PConstrApp constr -> | PConstrApp constr ->
let (constr, _) = r_split constr in let (constr, _) = r_split constr in
let (constr, patterns) = constr in let (constr, patterns) = constr in
let (constr, _) = r_split constr in let (constr, _) = r_split constr in
let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in
let pattern = Option.unopt ~default:(Var.of_name "_") pattern in let pattern = Option.unopt ~default:(Var.of_name "_") pattern in
ok (Constructor constr, pattern) return (Constructor constr, pattern)
) )
| _ -> fail @@ unsupported_pattern_type constr | _ -> fail @@ unsupported_pattern_type constr
in in
@ -479,7 +477,7 @@ fun compiler cases ->
let (case, _loc) = r_split case in let (case, _loc) = r_split case in
let%bind pattern = compile_pattern case.pattern in let%bind pattern = compile_pattern case.pattern in
let%bind expr = compiler case.rhs in let%bind expr = compiler case.rhs in
ok (pattern, expr) return (pattern, expr)
in in
let%bind cases = bind_map_ne_list aux cases in let%bind cases = bind_map_ne_list aux cases in
match cases with match cases with
@ -498,10 +496,9 @@ fun compiler cases ->
return @@ AST.Match_variant (List.combine constrs lst) return @@ AST.Match_variant (List.combine constrs lst)
| (p, _), _ -> fail @@ unsupported_pattern_type p | (p, _), _ -> fail @@ unsupported_pattern_type p
let compile_attribute_declaration attributes = let compile_attribute_declaration = function
match attributes with None -> return false
None -> ok @@ false | Some _ -> return true
| Some _ -> ok @@ true
let compile_parameters (params : CST.parameters) = let compile_parameters (params : CST.parameters) =
let compile_param_decl (param : CST.param_decl) = let compile_param_decl (param : CST.param_decl) =
@ -510,12 +507,12 @@ let compile_parameters (params : CST.parameters) =
let (pc, _loc) = r_split pc in let (pc, _loc) = r_split pc in
let (var, _) = r_split pc.var in let (var, _) = r_split pc.var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pc.param_type in let%bind param_type = bind_map_option (compile_type_expression <@ snd) pc.param_type in
ok @@ (var, param_type) return (var, param_type)
| ParamVar pv -> | ParamVar pv ->
let (pv, _loc) = r_split pv in let (pv, _loc) = r_split pv in
let (var, _) = r_split pv.var in let (var, _) = r_split pv.var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pv.param_type in let%bind param_type = bind_map_option (compile_type_expression <@ snd) pv.param_type in
ok @@ (var, param_type) return (var, param_type)
in in
let (params, _loc) = r_split params in let (params, _loc) = r_split params in
let params = npseq_to_list params.inside in let params = npseq_to_list params.inside in
@ -523,15 +520,15 @@ let compile_parameters (params : CST.parameters) =
let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction -> let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ result = fun ?next instruction ->
let return expr = match next with let return expr = match next with
Some e -> ok @@ e_sequence expr e Some e -> return @@ e_sequence expr e
| None -> ok @@ expr | None -> return expr
in in
let compile_tuple_expression (tuple_expr : CST.tuple_expr) = let compile_tuple_expression (tuple_expr : CST.tuple_expr) =
let (lst, loc) = r_split tuple_expr in let (lst, loc) = r_split tuple_expr in
let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in let%bind lst = bind_map_list compile_expression @@ npseq_to_list lst.inside in
match lst with match lst with
hd::[] -> ok @@ hd hd::[] -> return hd
| lst -> ok @@ e_tuple ~loc lst | lst -> return @@ e_tuple ~loc lst
in in
let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause -> let compile_if_clause : ?next:AST.expression -> CST.if_clause -> _ = fun ?next if_clause ->
match if_clause with match if_clause with
@ -553,14 +550,14 @@ let rec compile_instruction : ?next: AST.expression -> CST.instruction -> _ resu
Name var -> Name var ->
let (var,loc) = r_split var in let (var,loc) = r_split var in
let str = e_variable_ez ~loc var in let str = e_variable_ez ~loc var in
ok @@ (str, var, []) ok (str, var, [])
| Path proj -> | Path proj ->
let (proj, loc) = r_split proj in let (proj, loc) = r_split proj in
let (var, loc_var) = r_split proj.struct_name in let (var, loc_var) = r_split proj.struct_name in
let path = List.map compile_selection @@ npseq_to_list proj.field_path in let path = List.map compile_selection @@ npseq_to_list proj.field_path in
let (path, _) = List.split path in let (path, _) = List.split path in
let str = e_accessor ~loc (e_variable_ez ~loc:loc_var var) path in let str = e_accessor ~loc (e_variable_ez ~loc:loc_var var) path in
ok @@ (str, var, path) ok (str, var, path)
in in
let compile_lhs : CST.lhs -> _ = fun lhs -> let compile_lhs : CST.lhs -> _ = fun lhs ->
match lhs with match lhs with
@ -717,24 +714,23 @@ and compile_statement : ?next:AST.expression -> CST.attr_decl option -> CST.stat
match statement with match statement with
Instr i -> Instr i ->
let%bind i = compile_instruction ?next i in let%bind i = compile_instruction ?next i in
ok @@ (Some i, None) return (Some i, None)
| Data dd -> | Data dd ->
let next = Option.unopt ~default:(e_skip ()) next in let next = Option.unopt ~default:(e_skip ()) next in
let%bind dd = compile_data_declaration ~next ?attr dd in let%bind dd = compile_data_declaration ~next ?attr dd in
ok @@ (Some dd, None) return (Some dd, None)
| Attr at -> ok @@ (next, Some at) | Attr at -> return (next, Some at)
and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun ?next block -> and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun ?next block ->
let (block', _loc) = r_split block in let (block', _loc) = r_split block in
let statements = npseq_to_list block'.statements in let statements = npseq_to_list block'.statements in
let aux (next,attr) statement = let aux (next,attr) statement =
let%bind (statement, attr) = compile_statement ?next attr statement in let%bind (statement, attr) = compile_statement ?next attr statement in
ok @@ (statement,attr) return (statement,attr)
in in
let%bind (block', _) = bind_fold_right_list aux (next,None) statements in let%bind (block', _) = bind_fold_right_list aux (next,None) statements in
match block' with match block' with
Some block -> ok @@ block Some block -> return block
| None -> fail @@ block_start_with_attribute block | None -> fail @@ block_start_with_attribute block
and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) = and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; return=r; attributes}: CST.fun_decl) =
@ -744,7 +740,7 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
let%bind param = compile_parameters param in let%bind param = compile_parameters param in
let%bind r = compile_expression r in let%bind r = compile_expression r in
let (param, param_type) = List.split param in let (param, param_type) = List.split param in
let%bind body = Option.unopt ~default:(ok @@ r) @@ let%bind body = Option.unopt ~default:(return r) @@
Option.map (compile_block ~next:r <@ fst) block_with Option.map (compile_block ~next:r <@ fst) block_with
in in
(* This handle the parameter case *) (* This handle the parameter case *)
@ -774,16 +770,17 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; block_with; ret
let%bind func = match kwd_recursive with let%bind func = match kwd_recursive with
Some reg -> Some reg ->
let%bind fun_type = trace_option (untyped_recursive_fun loc) @@ fun_type in let%bind fun_type = trace_option (untyped_recursive_fun loc) @@ fun_type in
ok @@ e_recursive_ez ~loc:(Location.lift reg) fun_name fun_type lambda return @@ e_recursive_ez ~loc:(Location.lift reg) fun_name fun_type lambda
| None -> | None ->
ok @@ make_e ~loc @@ E_lambda lambda return @@ make_e ~loc @@ E_lambda lambda
in in
ok @@ (fun_name,fun_type, attr, func) return (fun_name,fun_type, attr, func)
(* Currently attributes are badly proccess, some adaptation are made to accomodate this (* Currently attributes are badly proccess, some adaptation are made to accomodate this
maked as ATR *) maked as ATR *)
let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = fun (attr, lst) decl -> let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = fun (attr, lst) decl ->
let return ?attr reg decl = ok @@ (attr, (Location.wrap ~loc:(Location.lift reg) decl)::lst) in (*ATR*) let return ?attr reg decl =
return (attr, (Location.wrap ~loc:(Location.lift reg) decl)::lst) in (*ATR*)
match decl with match decl with
TypeDecl {value={name; type_expr; _};region} -> TypeDecl {value={name; type_expr; _};region} ->
(* Todo : if attr isn't none, send warning *) (* Todo : if attr isn't none, send warning *)
@ -801,7 +798,7 @@ let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = f
let value = {value with attributes = attr} in (*ATR*) let value = {value with attributes = attr} in (*ATR*)
let%bind (fun_name,fun_type,attr,lambda) = compile_fun_decl value in let%bind (fun_name,fun_type,attr,lambda) = compile_fun_decl value in
return region @@ AST.Declaration_constant (Var.of_name fun_name, fun_type, attr, lambda) return region @@ AST.Declaration_constant (Var.of_name fun_name, fun_type, attr, lambda)
| AttrDecl decl -> ok @@ (Some decl, lst) (*ATR*) | AttrDecl decl -> ok (Some decl, lst) (*ATR*)
(* This should be change to the commented function when attributes are fixed (* This should be change to the commented function when attributes are fixed
let compile_program : CST.ast -> _ result = fun t -> let compile_program : CST.ast -> _ result = fun t ->
@ -812,4 +809,4 @@ let compile_program : CST.ast -> _ result =
let declarations = List.rev @@ nseq_to_list t.decl in let declarations = List.rev @@ nseq_to_list t.decl in
let attr = (None, []) in let attr = (None, []) in
let%bind (_, declarations) = bind_fold_list compile_declaration attr declarations in let%bind (_, declarations) = bind_fold_list compile_declaration attr declarations in
ok @@ declarations return declarations