remove fail

This commit is contained in:
galfour 2019-09-26 19:30:17 +02:00
parent ef2f6060d5
commit 7974469159
18 changed files with 26 additions and 120 deletions

View File

@ -50,7 +50,6 @@ type kwd_down = Region.t
type kwd_else = Region.t type kwd_else = Region.t
type kwd_end = Region.t type kwd_end = Region.t
type kwd_entrypoint = Region.t type kwd_entrypoint = Region.t
type kwd_fail = Region.t
type kwd_for = Region.t type kwd_for = Region.t
type kwd_from = Region.t type kwd_from = Region.t
type kwd_function = Region.t type kwd_function = Region.t
@ -343,7 +342,6 @@ and single_instr =
| Assign of assignment reg | Assign of assignment reg
| Loop of loop | Loop of loop
| ProcCall of fun_call | ProcCall of fun_call
| Fail of fail_instr reg
| Skip of kwd_skip | Skip of kwd_skip
| RecordPatch of record_patch reg | RecordPatch of record_patch reg
| MapPatch of map_patch reg | MapPatch of map_patch reg
@ -394,11 +392,6 @@ and record_patch = {
record_inj : record_expr record_inj : record_expr
} }
and fail_instr = {
kwd_fail : kwd_fail;
fail_expr : expr
}
and conditional = { and conditional = {
kwd_if : kwd_if; kwd_if : kwd_if;
test : expr; test : expr;
@ -757,7 +750,6 @@ let instr_to_region = function
| Single Loop For ForCollect {region; _} | Single Loop For ForCollect {region; _}
| Single ProcCall {region; _} | Single ProcCall {region; _}
| Single Skip region | Single Skip region
| Single Fail {region; _}
| Single RecordPatch {region; _} | Single RecordPatch {region; _}
| Single MapPatch {region; _} | Single MapPatch {region; _}
| Single SetPatch {region; _} | Single SetPatch {region; _}

View File

@ -34,7 +34,6 @@ type kwd_down = Region.t
type kwd_else = Region.t type kwd_else = Region.t
type kwd_end = Region.t type kwd_end = Region.t
type kwd_entrypoint = Region.t type kwd_entrypoint = Region.t
type kwd_fail = Region.t
type kwd_for = Region.t type kwd_for = Region.t
type kwd_from = Region.t type kwd_from = Region.t
type kwd_function = Region.t type kwd_function = Region.t
@ -327,7 +326,6 @@ and single_instr =
| Assign of assignment reg | Assign of assignment reg
| Loop of loop | Loop of loop
| ProcCall of fun_call | ProcCall of fun_call
| Fail of fail_instr reg
| Skip of kwd_skip | Skip of kwd_skip
| RecordPatch of record_patch reg | RecordPatch of record_patch reg
| MapPatch of map_patch reg | MapPatch of map_patch reg
@ -378,11 +376,6 @@ and record_patch = {
record_inj : field_assign reg injection reg record_inj : field_assign reg injection reg
} }
and fail_instr = {
kwd_fail : kwd_fail;
fail_expr : expr
}
and conditional = { and conditional = {
kwd_if : kwd_if; kwd_if : kwd_if;
test : expr; test : expr;

View File

@ -54,7 +54,6 @@
%token <Region.t> Else (* "else" *) %token <Region.t> Else (* "else" *)
%token <Region.t> End (* "end" *) %token <Region.t> End (* "end" *)
%token <Region.t> Entrypoint (* "entrypoint" *) %token <Region.t> Entrypoint (* "entrypoint" *)
%token <Region.t> Fail (* "fail" *)
%token <Region.t> For (* "for" *) %token <Region.t> For (* "for" *)
%token <Region.t> Function (* "function" *) %token <Region.t> Function (* "function" *)
%token <Region.t> From (* "from" *) %token <Region.t> From (* "from" *)

View File

@ -445,7 +445,6 @@ single_instr:
| assignment { Assign $1 } | assignment { Assign $1 }
| loop { Loop $1 } | loop { Loop $1 }
| proc_call { ProcCall $1 } | proc_call { ProcCall $1 }
| fail_instr { Fail $1 }
| Skip { Skip $1 } | Skip { Skip $1 }
| record_patch { RecordPatch $1 } | record_patch { RecordPatch $1 }
| map_patch { MapPatch $1 } | map_patch { MapPatch $1 }
@ -555,12 +554,6 @@ record_patch:
record_inj = $4} record_inj = $4}
in {region; value}} in {region; value}}
fail_instr:
Fail expr {
let region = cover $1 (expr_to_region $2)
and value = {kwd_fail = $1; fail_expr = $2}
in {region; value}}
proc_call: proc_call:
fun_call { $1 } fun_call { $1 }

View File

@ -287,7 +287,6 @@ and print_single_instr = function
| Assign assign -> print_assignment assign | Assign assign -> print_assignment assign
| Loop loop -> print_loop loop | Loop loop -> print_loop loop
| ProcCall fun_call -> print_fun_call fun_call | ProcCall fun_call -> print_fun_call fun_call
| Fail {value; _} -> print_fail value
| Skip kwd_skip -> print_token kwd_skip "skip" | Skip kwd_skip -> print_token kwd_skip "skip"
| RecordPatch {value; _} -> print_record_patch value | RecordPatch {value; _} -> print_record_patch value
| MapPatch {value; _} -> print_map_patch value | MapPatch {value; _} -> print_map_patch value
@ -295,10 +294,6 @@ and print_single_instr = function
| MapRemove {value; _} -> print_map_remove value | MapRemove {value; _} -> print_map_remove value
| SetRemove {value; _} -> print_set_remove value | SetRemove {value; _} -> print_set_remove value
and print_fail {kwd_fail; fail_expr} =
print_token kwd_fail "fail";
print_expr fail_expr
and print_conditional node = and print_conditional node =
let {kwd_if; test; kwd_then; ifso; terminator; let {kwd_if; test; kwd_then; ifso; terminator;
kwd_else; ifnot} = node in kwd_else; ifnot} = node in

View File

@ -787,10 +787,6 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu
let%bind lst = bind_map_list simpl_expression args' in let%bind lst = bind_map_list simpl_expression args' in
return_statement @@ e_constant ~loc s lst return_statement @@ e_constant ~loc s lst
) )
| Fail e -> (
let%bind expr = simpl_expression e.value.fail_expr in
return_statement @@ e_failwith expr
)
| Skip reg -> ( | Skip reg -> (
let loc = Location.lift reg in let loc = Location.lift reg in
return_statement @@ e_skip ~loc () return_statement @@ e_skip ~loc ()

View File

@ -45,10 +45,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind path' = map_path f path in let%bind path' = map_path f path in
return @@ E_assign (name , path' , e') return @@ E_assign (name , path' , e')
) )
| E_failwith e -> (
let%bind e' = self e in
return @@ E_failwith e'
)
| E_matching (e , cases) -> ( | E_matching (e , cases) -> (
let%bind e' = self e in let%bind e' = self e in
let%bind cases' = map_cases f cases in let%bind cases' = map_cases f cases in

View File

@ -206,14 +206,6 @@ module Errors = struct
] in ] in
error ~data title message () error ~data title message ()
let deprecated_fail (ae : I.expression) () =
let title () = "fail is deprecated, use failwith instead" in
let message = title in
let data = [
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location) ;
] in
error ~data title message ()
let constant_error loc lst tv_opt = let constant_error loc lst tv_opt =
let title () = "typing constant" in let title () = "typing constant" in
let message () = "" in let message () = "" in
@ -404,7 +396,6 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
trace main_error @@ trace main_error @@
match ae.expression with match ae.expression with
(* Basic *) (* Basic *)
| E_failwith _ -> fail @@ deprecated_fail ae
| E_variable name -> | E_variable name ->
let%bind tv' = let%bind tv' =
trace_option (unbound_variable e name ae.location) trace_option (unbound_variable e name ae.location)
@ -653,32 +644,6 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
(* Advanced *) (* Advanced *)
| E_matching (ex, m) -> ( | E_matching (ex, m) -> (
let%bind ex' = type_expression e ex in let%bind ex' = type_expression e ex in
match m with
(* Special case for assert-like failwiths. TODO: CLEAN THIS. *)
| I.Match_bool { match_false ; match_true } when I.is_e_failwith match_true -> (
let%bind fw = I.get_e_failwith match_true in
let%bind fw' = type_expression e fw in
let%bind mf' = type_expression e match_false in
let t = get_type_annotation ex' in
let%bind () =
trace_strong (match_error ~expected:m ~actual:t ae.location)
@@ assert_t_bool t in
let%bind () =
trace_strong (match_error
~msg:"matching not-unit on an assert"
~expected:m
~actual:t
ae.location)
@@ assert_t_unit (get_type_annotation mf') in
let mt' = make_a_e
(E_constant ("ASSERT_INFERRED" , [ex' ; fw']))
(t_unit ())
e
in
let m' = O.Match_bool { match_true = mt' ; match_false = mf' } in
return (O.E_matching (ex' , m')) (t_unit ())
)
| _ -> (
let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae ae.location in let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae ae.location in
let tvs = let tvs =
let aux (cur:O.value O.matching) = let aux (cur:O.value O.matching) =
@ -701,7 +666,6 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
tv_opt in tv_opt in
return (O.E_matching (ex', m')) tv return (O.E_matching (ex', m')) tv
) )
)
| E_sequence (a , b) -> | E_sequence (a , b) ->
let%bind a' = type_expression e a in let%bind a' = type_expression e a in
let%bind b' = type_expression e b in let%bind b' = type_expression e b in
@ -876,9 +840,6 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
let%bind ae' = untype_expression ae in let%bind ae' = untype_expression ae in
let%bind m' = untype_matching untype_expression m in let%bind m' = untype_matching untype_expression m in
return (e_matching ae' m') return (e_matching ae' m')
| E_failwith ae ->
let%bind ae' = untype_expression ae in
return (e_failwith ae')
| E_sequence _ | E_sequence _
| E_loop _ | E_loop _
| E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression | E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression

View File

@ -253,10 +253,6 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind rhs' = transpile_annotated_expression rhs in let%bind rhs' = transpile_annotated_expression rhs in
let%bind result' = transpile_annotated_expression result in let%bind result' = transpile_annotated_expression result in
return (E_let_in ((binder, rhs'.type_value), rhs', result')) return (E_let_in ((binder, rhs'.type_value), rhs', result'))
| E_failwith ae -> (
let%bind ae' = transpile_annotated_expression ae in
return @@ E_constant ("FAILWITH" , [ae'])
)
| E_literal l -> return @@ E_literal (transpile_literal l) | E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> ( | E_variable name -> (
let%bind ele = let%bind ele =

View File

@ -52,8 +52,6 @@ let rec expression ppf (e:expression) = match e.expression with
expression result expression result
| E_matching (ae, m) -> | E_matching (ae, m) ->
fprintf ppf "match %a with %a" expression ae (matching expression) m fprintf ppf "match %a with %a" expression ae (matching expression) m
| E_failwith ae ->
fprintf ppf "failwith %a" expression ae
| E_sequence (a , b) -> | E_sequence (a , b) ->
fprintf ppf "%a ; %a" fprintf ppf "%a ; %a"
expression a expression a

View File

@ -84,7 +84,6 @@ let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {mat
let e_accessor ?loc a b = location_wrap ?loc @@ E_accessor (a , b) let e_accessor ?loc a b = location_wrap ?loc @@ E_accessor (a , b)
let e_accessor_props ?loc a b = e_accessor ?loc a (List.map (fun x -> Access_record x) b) let e_accessor_props ?loc a b = e_accessor ?loc a (List.map (fun x -> Access_record x) b)
let e_variable ?loc v = location_wrap ?loc @@ E_variable v let e_variable ?loc v = location_wrap ?loc @@ E_variable v
let e_failwith ?loc v = location_wrap ?loc @@ E_failwith v
let e_skip ?loc () = location_wrap ?loc @@ E_skip let e_skip ?loc () = location_wrap ?loc @@ E_skip
let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body) let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body)
let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b) let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b)
@ -167,13 +166,6 @@ let get_e_tuple = fun t ->
| E_tuple lst -> ok lst | E_tuple lst -> ok lst
| _ -> simple_fail "not a tuple" | _ -> simple_fail "not a tuple"
let get_e_failwith = fun e ->
match e.expression with
| E_failwith fw -> ok fw
| _ -> simple_fail "not a failwith"
let is_e_failwith e = to_bool @@ get_e_failwith e
let extract_pair : expression -> (expression * expression) result = fun e -> let extract_pair : expression -> (expression * expression) result = fun e ->
match e.expression with match e.expression with
| E_tuple [ a ; b ] -> ok (a , b) | E_tuple [ a ; b ] -> ok (a , b)

View File

@ -163,7 +163,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| (E_variable _, _) | (E_lambda _, _) | (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _) | (E_application _, _) | (E_let_in _, _)
| (E_accessor _, _) | (E_accessor _, _)
| (E_look_up _, _) | (E_matching _, _) | (E_failwith _, _) | (E_sequence _, _) | (E_look_up _, _) | (E_matching _, _) | (E_sequence _, _)
| (E_loop _, _) | (E_assign _, _) | (E_skip, _) -> simple_fail "comparing not a value" | (E_loop _, _) | (E_assign _, _) | (E_skip, _) -> simple_fail "comparing not a value"
let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)

View File

@ -65,7 +65,6 @@ and expression' =
| E_look_up of (expr * expr) | E_look_up of (expr * expr)
(* Matching *) (* Matching *)
| E_matching of (expr * matching_expr) | E_matching of (expr * matching_expr)
| E_failwith of expr
(* Replace Statements *) (* Replace Statements *)
| E_sequence of (expr * expr) | E_sequence of (expr * expr)
| E_loop of (expr * expr) | E_loop of (expr * expr)

View File

@ -47,7 +47,6 @@ and expression ppf (e:expression) : unit =
| E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i | E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i
| E_matching (ae, m) -> | E_matching (ae, m) ->
fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
| E_failwith ae -> fprintf ppf "failwith %a" annotated_expression ae
| E_sequence (a , b) -> fprintf ppf "%a ; %a" annotated_expression a annotated_expression b | E_sequence (a , b) -> fprintf ppf "%a ; %a" annotated_expression a annotated_expression b
| E_loop (expr , body) -> fprintf ppf "while %a { %a }" annotated_expression expr annotated_expression body | E_loop (expr , body) -> fprintf ppf "while %a { %a }" annotated_expression expr annotated_expression body
| E_assign (name , path , expr) -> | E_assign (name , path , expr) ->

View File

@ -176,7 +176,6 @@ module Free_variables = struct
| (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m | (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
| E_look_up (a , b) -> unions @@ List.map self [ a ; b ] | E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
| E_matching (a , cs) -> union (self a) (matching_expression b cs) | E_matching (a , cs) -> union (self a) (matching_expression b cs)
| E_failwith a -> self a
| E_sequence (a , b) -> unions @@ List.map self [ a ; b ] | E_sequence (a , b) -> unions @@ List.map self [ a ; b ]
| E_loop (expr , body) -> unions @@ List.map self [ expr ; body ] | E_loop (expr , body) -> unions @@ List.map self [ expr ; body ]
| E_assign (_ , _ , expr) -> self expr | E_assign (_ , _ , expr) -> self expr
@ -476,7 +475,7 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
| (E_literal _, _) | (E_variable _, _) | (E_application _, _) | (E_literal _, _) | (E_variable _, _) | (E_application _, _)
| (E_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _) | (E_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _)
| (E_record_accessor _, _) | (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _) | (E_failwith _, _) | (E_look_up _, _) | (E_matching _, _)
| (E_assign _ , _) | (E_assign _ , _)
| (E_sequence _, _) | (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b | (E_sequence _, _) | (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b

View File

@ -88,7 +88,6 @@ module Captured_variables = struct
let%bind a' = self a in let%bind a' = self a in
let%bind cs' = matching_expression b cs in let%bind cs' = matching_expression b cs in
ok @@ union a' cs' ok @@ union a' cs'
| E_failwith a -> self a
| E_sequence (_ , b) -> self b | E_sequence (_ , b) -> self b
| E_loop (expr , body) -> | E_loop (expr , body) ->
let%bind lst' = bind_map_list self [ expr ; body ] in let%bind lst' = bind_map_list self [ expr ; body ] in

View File

@ -105,7 +105,6 @@ and expression =
| E_look_up of (ae * ae) | E_look_up of (ae * ae)
(* Advanced *) (* Advanced *)
| E_matching of (ae * matching_expr) | E_matching of (ae * matching_expr)
| E_failwith of ae
(* Replace Statements *) (* Replace Statements *)
| E_sequence of (ae * ae) | E_sequence of (ae * ae)
| E_loop of (ae * ae) | E_loop of (ae * ae)

View File

@ -41,7 +41,7 @@ function transfer_single(const action : action_transfer_single ; const s : stora
begin begin
const cards : cards = s.cards ; const cards : cards = s.cards ;
const card : card = get_force(action.card_to_transfer , cards) ; const card : card = get_force(action.card_to_transfer , cards) ;
if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ; if (card.card_owner =/= source) then failwith ("This card doesn't belong to you") else skip ;
card.card_owner := action.destination ; card.card_owner := action.destination ;
cards[action.card_to_transfer] := card ; cards[action.card_to_transfer] := card ;
s.cards := cards ; s.cards := cards ;
@ -51,7 +51,7 @@ function transfer_single(const action : action_transfer_single ; const s : stora
function sell_single(const action : action_sell_single ; const s : storage_type) : (list(operation) * storage_type) is function sell_single(const action : action_sell_single ; const s : storage_type) : (list(operation) * storage_type) is
begin begin
const card : card = get_force(action.card_to_sell , s.cards) ; const card : card = get_force(action.card_to_sell , s.cards) ;
if (card.card_owner =/= source) then fail "This card doesn't belong to you" else skip ; if (card.card_owner =/= source) then failwith ("This card doesn't belong to you") else skip ;
const card_pattern : card_pattern = get_force(card.card_pattern , s.card_patterns) ; const card_pattern : card_pattern = get_force(card.card_pattern , s.card_patterns) ;
card_pattern.quantity := abs(card_pattern.quantity - 1n); card_pattern.quantity := abs(card_pattern.quantity - 1n);
const card_patterns : card_patterns = s.card_patterns ; const card_patterns : card_patterns = s.card_patterns ;
@ -71,7 +71,7 @@ function buy_single(const action : action_buy_single ; const s : storage_type) :
// Check funds // Check funds
const card_pattern : card_pattern = get_force(action.card_to_buy , s.card_patterns) ; const card_pattern : card_pattern = get_force(action.card_to_buy , s.card_patterns) ;
const price : tez = card_pattern.coefficient * (card_pattern.quantity + 1n) ; const price : tez = card_pattern.coefficient * (card_pattern.quantity + 1n) ;
if (price > amount) then fail "Not enough money" else skip ; if (price > amount) then failwith ("Not enough money") else skip ;
// Administrative procedure // Administrative procedure
const operations : list(operation) = nil ; const operations : list(operation) = nil ;
// Increase quantity // Increase quantity